perm filename LISP[NEW,LSP]9 blob
sn#464224 filedate 1979-07-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00613 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00076 00002 .MLLIT VERSION ITS TOPS10 TOPS20 SAIL TENEX CMU KA10 KI10 KL10 ML BIGNUM OBTSIZ PTCSIZ NEWRD JOBQIO HNKLOG SFA LHFLAG NIOBFS USELESS DBFLAG CXFLAG NARITH
C00081 00003
C00085 00004 LVRNO LVRNO ZZZ ZZZ DEFAULT
C00089 00005 D10 D20 ZZZ SEGLOG OBTSIZ DXFLAG
C00091 00006 $GET
C00096 00007 NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP
C00101 00008 LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS NERINT NERINT
C00105 00009
C00109 00010 %SY %SYHKL %SYKIL %SYLCL %SYGBL BYTSWD
C00112 00011 LS ST.LS $FS ST.$FS FX ST.FX FL ST.FL BN ST.BGN SY ST.SY SA ST.SA VC ST.VAC $PDLNM ST.$PDLNM $XM ST.$XM $NXM ST.$NXM PUR ST.PUR HNK ST.HNK DB ST.DB CX ST.CX DX ST.DX RN NUM ST.
C00115 00012
C00118 00013
C00121 00014 LABEL
C00124 00015 NBITMACS NBITMACS XX YY
C00127 00016
C00131 00017 SYMVC SYMARGS SYMPNAME SY.ONE SY.LAP SY.PUR SY.CCN SY.OTC SY.ZER SY.
C00134 00018 ASAR TTSAR AS.SFA AS.JOB AS.FIL AS.RDT AS.OBA AS.DX AS.CX AS.DB AS.SX AS.FX AS.FL AS.GCP TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D
C00140 00019 FI.EOF FO.EOP FJ.INT FI.BBC FI.BBF TI.BFN FT.CNS F.GC F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.EC FBT.SE FBT.FU FBT.ND FBT.SC F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 L.D6BT L.N6BT L.F6BT F.RDEV F.RFN1 F.RFN2 L.6DEV L.6DIR L.6FNM L.6EXT L.6VRS F.DEV F.DIR F.FNM F.EXT F.VRS L.D6BT L.N6BT L.F6BT LOPOFA TI.ST1 TI.ST2 ATO.LC AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FO.RPL LONBFA FB.BYT FB.BFL FB.BVC FB.IBP FB.BP FB.CNT FB.HED FB.NBF FB.BWS FB.BUF
C00152 00020 J.INTF J.CINT J.LFNM J.CRUFT J.GC J.INTB J.STAD J.UIND LOJOBA J.SYMS
C00154 00021 SR.CAL SFCALI SR.WOM SR.UDL SO.OPN SO.CLO SO.REN SO.DEL SO.TRP SO.PR1 SO.TYI SO.UNT SO.TIP SO.IN SO.EOF SO.TYO SO.OUT SO.FOU SO.RED SO.RDL SO.PRT SO.PRC SO.MOD SO.POS SR.FML SR.FUN SR.PNA SR.FUS SR.LEN STPFL NM
C00159 00022
C00161 00023 %HISEG %LOSEG CURSTD %LOSEG %HISEG CURSTD
C00163 00024
C00164 00025 ZZZ ZZZ
C00165 00026 PGTPMK NPGTPS
C00167 00027 ZZY ZZ ZZX ZZY
C00170 00028 NPURTR NIOCTR
C00173 00029 N2DIF
C00175 00030 NPRO
C00177 00031 ZZ ZZ ZZ GS SEGBYT LONUM HINUM PAGSIZ PAGMSK PAGKSM NPAGS NNUMTP NTYPES
C00182 00032 SEGSIZ SEGMSK SEGKSM NSEGS BTBSIZ SGS%PG BTSGGS ALPDL ALFXP ALFLP ALSPDL ALFXP ALFLP ALPDL ALSPDL
C00185 00033 IB.ALARM IB.TIMER IB.PARITY IB.FLOV IB.PURE IB.PCPURE IB.SYSUUO IB.AT3 IB.AT2 IB.AT1 IB.DEBUG IB.RVIOL IB.CLI IB.PDLOV IB.LTPEN IB.MAR IB.MPV IB.SCLK IB.1PROC IB.BREAK IB.ILAD IB.IOC IB.VALUE IB.DOWN IB.ILOP IB.DMPV IB.AROV IB.42BAD IB.C.Z IB.TTY IB.PDLOV IB.MPV
C00189 00034 TOPN BOTN NPURTR NIOCTR N2DIF NPRO %LOSEG %HISEG FIRSTLOC STDLO STDHI CURSTD STDLO STDHI CURSTD LISPSW SUSFLS
C00192 00035 TWENTY THIRTY FORTY UUOGLEEP JPCSAV
C00194 00036 NSFC NSFC NSFC
C00196 00037 UNBND2 ABIND3 SETXIT SPECX AYNVSFX 1DIMS ARYGET ARYGT4 ARYGT8 1DIMF ANYGET 1DIMD ADYGET 1DIMZ AZYGET SPSV
C00199 00038 INTFLG NOQUIT UNREAL ERRSVD IMASK LFAKP LFAKFXP FAKP FAKFXP MONL6P KA10P UPIINT CCOCW1 CCOCW2 TENEXP INTPC1 INTPC2 INTPC3 PDLSVT SUPSAV LV2SVT LV2SVF LV2ST2 LV3SVT LV3SVF LV3ST2 DSMSAV CINTAB CINTSZ
C00205 00039 STTYW1 STTYW2 STTYL1 STTYL2 STTYA1 STTYA2 CCOC1 CCOC2 XACTW XACTL STDTIW SACTW1 SACTW2 SACTW3 SACTW4 SACTL1 SACTL2 SACTL3 SACTL4
C00208 00040 UISTAK GCRSR PDLSTH PDLSTA PDLSTB PDLSTC
C00209 00041 CHNTB TMPC DPAGEL DLINEL LJOBTB JOBTB
C00211 00042 TTYIF1 TTYIF2 FI.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 F.RDEV F.DEV
C00216 00043 TTYOF1 TTYOF2 FO.EOP FT.CNS F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 F.RDEV F.DEV FO.LNL FO.PGL FO.RPL
C00218 00044 SWS ERRTN CATRTN EOFRTN PA4 INHIBIT ERRSW BFPRDP CATID CATSPC CATLIS CATUWP CATCAB CATALL CATCOM LEP1 UIRTN RSXTB PNMK1 GCD.A UNBND3 SIXMK2 SAVMAR GCD.B AUNBD EXP.S ATAN.S UNMTMP FPTEM IFLT9 EQLP GCD.C ATAN.X GWDCNT GCD.D ATAN.Y GWDORG GWDRG1
C00223 00045 EXPL5 GCD.UH BKTRP EV0B FLAT1 MEMV UAPOS GCD.VH LPNF AUNBR DLTC RINF APFNG1 TABLU1 AUNBF MNMX0 GRESS0 GRESS0 CFAIL CSUCE BACTYF BOOLI TOPAST PLUS0 PLUS3 PLUS6 PLUS8 RM4 SWNACK RDBKBF RDBKC RDNSV RDDSV RDIBS RDINCH CORBP MKNCH
C00227 00046 PNBP PNBUF JCLBF ATMBF REMFL VETBL0 DVS1 DVS2 DVSL DD1 DD2 DD3 DDL NORMF QHAT BNMSV FACF FACD AGDBT YAGDBT TSAVE DSAVE RSAVE FSAVE NRD10FL LJCLBF UUOH ERROR ERBDF UUOFN UUTSV UUTTSV UURSV UUALT9 UUPSV UUOBKG LUUSV LSWS
C00230 00047 FFS FFX FFL FFY FFA NFF FFY2 NPFFS NPFFX NPFFL NPFFY2 EPFFS EPFFX EPFFL EPFFY2 EFVCS NFVCP FFVC ETVCFLSP
C00234 00048 GCMKL PROLIS MFFS MFFX MFFL MFFY MFFA NFFS NFFX NFFL NFFY NFFA GCWHO GCWHO1 GCWHO2 GCWHO3 GCACSAV GCNASV GCP GCFLP GCFXP GCSP PANICP GCMRKV GCTIM GCTM1 GCUUSV IRMVF GCRMV ARPGCT
C00239 00049 ZFFS ZFFX ZFFL ZFFY ZFFA SFSSIZ SFXSIZ SFLSIZ SSYSIZ SSASIZ OFSSIZ OFXSIZ OFLSIZ OSYSIZ OSASIZ GFSSIZ GFXSIZ GFLSIZ GSYSIZ GSASIZ
C00242 00050 FSSGLK FXSGLK FLSGLK SYSGLK SASGLK S2SGLK BTSGLK IMSGLK PRSGLK BTBAOB MAINBITBLT GC98 GC99 PFSSIZ PFXSIZ PFLSIZ PS2SIZ
C00245 00051 BPSH BPSL HINXM HIXM MAXNXM HBPORG HBPEND NPDLL NPDLH PDLFL1 PDLFL2 XFFS XFFX XFFL XFFY XFFA XPDL XFLP XFXP XSPDL ZPDL ZFLP ZFXP ZSPDL C2 FLC2 FXC2 SC2 ZSC2 OC2 OFLC2 OFXC2 OSC2
C00249 00052 INTAR UNRC.G UNRRUN UNRTIM UNREAR LIPSAV IPSWD1 IPSWD2 IPSDF1 IPSDF2 IPSPC IPSD IPSR IPSF MXIPDL LINTPDL INTPDL ACBASE INTPAR INTCLK INTTTI INTPOV INTILM INTNXM REEINT REENOP APRSVT REESVT INTALL %PIPAR %PIWRO %PIMPV %PIILO
C00254 00053 MUNGP ERRPAD ERRPST BFTMPS SQ6BIT SQSQOZ LDBYTS LDOFST LDAAOB LDTEMP LD6BIT LDAPTR LDBPTR LDF2DP LDASAR LDBSAR LDXBLT LDXSIZ LDXSM1 LDXDIF LDHLOC LDEOFJ LFTMPS LDHSH2 LDHSH2 LDHSH2 LDX%FU LDXPSP LDXOFS LDXPNT LDXLPC LDXLPL LDXHS1 LDXHS2 LDXPFG
C00261 00054 USN EVPUNT UWUSN D10PTR D10ARD D10NAM D10REN SYMLO %TXTOP %TXSFL %TXSFT %TXMTA %TXCTL %TXASC RDOBJ8 ALGCF AFILRD GNUM RNOWS RBACK RBLOCK
C00264 00055 RNTN2 BPPNR GAMNT GSBPN ADDSAR TOTSPC LLIP1 INSP RTSP1 RTSP3 LOSEF RWG FLOV9A FLOV9B CPJSW PSYMF POFF PSMS PSMTS PSMRS PS.S STQLUZ NOPFLS SAWSP PURDEV PURFN1 PURFN2 PURSNM SYSDEV SYSFN1 SYSFN2 SYSSNM
C00267 00056 KILHG4 KILHG2 KILHG3 KILHGH KILHG1 KILHG1 KILHG2 GETHGH GETHG1 GETHG2 GETHG1 RETHGH GLSLUY GLSLUA CHKHGH GLSLZ4 GLSLZ0 GLSLZA GLSLZ1 GLSLM1 GLSLZ2 GLSLM2 GLSLZ3 GLSLM3 SGANAM SGADEV SGAPPN SGAEXT LDRIHS LDRHS1 LDSCRU SJCLBUF
C00278 00057 RSXTB1 RCT IOBAR1 IOBAR2 PURTBL ZZW ZZZ $ NLBTSG NHBTSG ZZX ZZX ZZZ FLSTBL ZZX ZZX
C00282 00058 ZZ LOBITSG TOP.PG BTBLKS LOBITSG
C00284 00059 ST STDISP
C00289 00060 GCBMRK GCBCDR GCBCAR GCB ZZZ GCBFOO ZZZ
C00293 00061 GCST BTB. LXXBSG
C00295 00062 NNPUSH N0PUSH N0.0PUSH BPURPG $$$NIL EPRNT1 EPRNT2 EPRNT3 ERROR1 EROR1Z EROR1A MSGFCK CMSGFCK
C00299 00063 ERROR9 LERFRAME EROR9A ERRRTN ERR2 LSPRT0 CLSPRET
C00302 00064 ERROR3 EROR3C EROR3E EROR3F
C00304 00065 ERROR5 EROR5F EROR5A EROR6A ERRV
C00307 00066 ERRIOJ ERIOJ1 ERIOJ2 ERIOJ3 ERIOJ4 ERIOJ5 ERIOJ8 ERIOJ7 ERIO6B ERIOJ6 ERIO6A ERIOJ9 ERTBL ERFNF% ERIPP% ERPRT% ERFBM% ERAEF% ERISU% ERTRN% ERNSF% ERNEC% ERDNA% ERNSD% ERILU% ERNRM% ERWLK% ERNET% ERPOA% ERBNF% ERCSD% ERDNE% ERSNF% ERSLE% ERLVL% ERNCE% ERSNS% ERFCU% ERLOH% ERNLI% LERTBL
C00316 00067 PDLOV PDLH0 PDLOV1 PDLRET PDLH4 PDLLOS PDLMSG
C00321 00068 PDLOV5 PDLOV6
C00323 00069 ERRBAD UUOGL1 UUOGL2 UUOGL7 UUOGL8
C00325 00070 UUONVE NTHIEN NTHER LASTER UUOMER UUOFER REMAIR UNOVER OVFLER UNFLER ER2 ER3 ER4 RDNMER ADEAD EG1 INTNCO BADOB
C00328 00071 DFPER DEFNER REVER PNGE PNGE1 NASER SBADSP CA.DER CA.DE1 CA.DE2 CA.DE3
C00330 00072 NILSETQ TSETQ XSETQ STORE5 RPLCA0 RPLCD0 RPLCA1 RPLCD1 %ARR0A %ARR0 %ARR0B LDGETQ LDXERR LDALREADY LDATE9 LDATER
C00333 00073 IBSERR BASER %LVERR %LNERR
C00334 00074 NIHIL VERITAS PURITAS POVPDL POVFLP POVFXP POVSPDL MESMAJ UNRECOV FLNMER $ARERR IARERR FXNMER NMV3 CAMMES MES2 MES3 MES5 MES6 MES14 MES18 MES19 MES20 MES21 EMS1 EMS3 EMS5 EMS6 EMS10 EMS12 EMS13 EMS15 EMS16 EMS18 EMS21 EMS22 EMS25 EMS26 EMS29 EMS31 EMS34 STRTCR
C00338 00075 ERRERC ERRERO ERERER EVAL.A EVAL.1 .UDT .UDT1 .UDT2
C00340 00076 ESB6 WNAERR WNAER1 QF3A QF2A QF1A UUOH3C UUOH3A UUOUER UUOUE1 UUOUE2 EPRINT
C00342 00077 EV3B EV3A EV3J IAP2A IAP2J WNAL0 WNALOSE WNAL1 STERR WNAFOSE FASLUR FASLUH FASLNX FASLNC LDFERR
C00344 00078 LMBERR LXPRLZ DOERRE GETLE GETLE1 SETWNA SIGNPE PROPER RMPER0 LFYER GENSY8 ARGCM8 ARGCM0 ARGCM1 ARGCM2
C00346 00079 PTRCKE .STOLZ TYOAGE GTRDT9 EOFE EOFE1 MAPWNA MEMQER DLTER LIST.9 SUSPE
C00349 00080 GTPDL1 RAND9 S2WNAL TYPKER S1WNAL GRCTIE FRERR CRSRP2 ALST0 LFY0 ALCK0 PRGER1 DOERR DO5ER
C00351 00081 ATAN.7 EXP.ER EXPER1 SIN.ER COS.ER SQR$ER LOG.ER NUMER ARTHER 1EQNF 1GPNF 2EQNF 2GPNF ALHNKE
C00353 00082 GCMLOSE GCMES GCLSMS GCLUZ GCLUZ3 GCLUZ5 GCLUZ4 GCLUZ6 GCLUZ7 GCPDLOV DIE
C00356 00083 ERRADR ERRAD1 ERRDCD CPRIN1 ERRO2E ERRO2Q ERRO2A ERRO2C ERRO2H ERRO2G ERRO2B ERRO2R
C00359 00084 BEGFUN $ERROR ERRERB ERRERN ERRERD SUBR
C00361 00085 ERRFRAME EPR6 EPR7 EPR5 EPR1 EPR4 EPR3
C00364 00086 ERRPRINT OFCAN
C00366 00087 LSPRET LSPRT1 HACENT LISP1 LISP2 LISP2A LISP2B
C00370 00088 STDIFL TLTERPRI TLTERX TLTER1
C00373 00089 TLREAD TLRED1 TLRED2 SPCFLS
C00376 00090 TLEVAL CEVAL NILBAD CSETZ PDLCHK PDLCRP
C00379 00091 LINMDP TLPRINT TLPR1 IPRIN1
C00382 00092 TLVRSS TLVRS1 SIXJBN
C00383 00093 ERINIT ERINIX ERINI8 ERIN8G ERINI0
C00386 00094 ERINI2 ERINI5 ERIN5C ERIN5D ERIN5A ERIN5B ERINI6 ERIN6A ERINI3 SARTOB SATOB1 SATOB7 LPROGZ PDLFLS
C00389 00095 SPECBIND SPEC1 SPEC2 SPEC6 SPEC5 SPEC4 SPEC3
C00392 00096 ERRPOP ERRPNU UBD0 UBD UBD3 UBD1 UBD4 UNBIND UNBND0 UNBND1
C00394 00097 BIND BIND4 STQPUR BIND5 CBIND4 BIND1 POPBJ CPOPBJ MAKVC MAKVC0 MAKVC1 MAKVCX MAKVC3
C00397 00098 C1CONS %NCONS NCONS ACONS BGNMAK BNCONS
C00399 00099 SIXMAK SIXMK1 .UDT4 SIXATM SIXAT1 PNBFAT PNBFA1 PNBFMK PNBFM6
C00402 00100 PPNATM PPNAT2 PPNAT4 PPNAT6 PPNAT3 PPNAT5
C00405 00101 CATPUS CATPS1 CATBAR CTCALL THRALL THROW5 THROW1 THROW6 THRNXT THROW7 THROW3 THRXIT THRSPC THRCAB THROW4 ERUNDO ERR0 GOBRK IOGBND EPOPJ
C00412 00102 BRGEN BRLP1 BRLP BRLP2 BRLP4 BRLP3
C00415 00103 .STORE .STOR0 .STOR1 .STOR2 .STOR4 .STOR4
C00418 00104 .SET .SET1 FWNACK FWNAC1 LWNACK ERSTP LERSTP ERUN0 ERR1A ERR1 EPC1
C00422 00105 UIBRK UNWPRO UNWPR2 UNWPR1 UNWPUS UNWNCM UNWNXT UNWPRT
C00428 00106 CIN0 CONS1PFX CONS1FX CONSPFX CONSFX CONSIT BAPOPJ ZPOPJ POPNVJ CCPOPJ 0POPJ POP2J CPOPJ POP3J POPAJ1 S1PAJ POPAJ CPOPAJ POP1J1 POPJ1 POP1J CPOP1J M1TTPJ POPCJ CPOPCJ UNLKFALSE UNLKTRUE PX1J CPXDFLJ PXDFLJ POPXDJ CPXDJ
C00432 00107 SAV5 SAV5M1 SAV5M2 SAV5M3 CPOPXJ SAV3 SAV2 SAV1 RST3 RST2 RST1 RST5 R5M1PJ RST5M1 CR5M1PJ RST5M2 RST5M3 SAVX5 SAVX3 RSTX5 PXTTTJ POPXTJ RSTX3 RSTX2 RSTX1 CPOPNVJ
C00434 00108 $ERRFRAME $EVALFRAME $UIFRAME L$EVALFRAME AFPOPJ $APPLYFRAME
C00436 00109 FLTSK1 FLTSK2 FLTSKP FLTSTB FLTSFX FLTSFL NVSKP2 NVSKIP NVSKTB NVSKFL
C00439 00110 NMSKP2 NMSKIP NMSKTB NMSKFX NMSKFL
C00441 00111 LR70 CDUPL1 CCMPL1 CDBL1 CFIX1 CFLOAT1 R70 ZZZ XC IFIX IFLOAT IFLT5 IFLT1 IFLT2 IFLT4 IFLT3
C00444 00112 FLNV1X EFLNV1 FLNV1 EDBNV1 DBNV1 CXNV1X ECXNV1 CXNV1 EDXNV1 DXNV1 RSXST
C00447 00113 NPUSH 0PUSH 0.0PUSH CINTREL INTREL CHECKI ERSETUP
C00449 00114 .LCALL .LCAF5 .LCAF7 .LCAFX .LCAFL .LCADB .LCACX .LCADX
C00453 00115 NORET .RSET NOUUO LIST LISTX LISTX3 KLIST JLIST ILIST ILIST1 ILIST3 GTRDTB GTRDT8
C00456 00116 NOINTERRUPT NOINT0 CHECKU CHECKQ NOINT1 NOINT5 NOINT3 NOINT4 NOINTA NOINT2 ENOINT
C00459 00117 CARCDR %CADDDR %CADDAR %CADDR %CADAR %CADR %CAAR %CAR %CDDDDR %CDDDAR %CDDDR %CDDAR %CDDR %CDAR %CDR %CAADDR %CAADAR %CAADR %CAAAR %CDADDR %CDADAR %CDADR %CDAAR %CAAADR %CAAAAR %CDDADR %CDDAAR %CDAADR %CDAAAR %CADADR %CADAAR
C00462 00118 %CARCDR CRSUBRS CR0 CR1 CR1A CR2 CR3 CR7 CR4 CR5 CR6 NTH NTHCDR NTHCD5 NTHCD6 NTHCD1 NTHCD0 NTHCD2 NTHCD4
C00469 00119 PNGNK PNGNK1 PNGNK2 SYCONS SYCON2 SYCON1 PSYCONS PNCONS PNG2 CPXTJ
C00472 00120 XCONS CONS CONS1 CONS3 $NCONS $XCONS LIST. %PDLNC %PDLXC %PDLC %XCONS %CONS %CONS1 %CONS3 %C2NS $C2NS
C00477 00121 FIX2 FIX1 FXCONS FIX1A FWCONS FLCONX FLOAT2 FLOAT1 FLCONS FPCONS
C00479 00122 DBL1 DBCONS DBCONS DBL1 CXCONX CMPL1 CXCONS CXCONS CMPL1 DUPL1 DXCONS DXCONS DUPL1
C00481 00123 %HUNK1 %HUNK2 %HUNK3 %HUNK4 %CXR %RPX CXR CXR2 RPLACX RPLX2 CXR30 CXR31 CXR3 CXR33 CXR34
C00484 00124 %CXR %CXR2 %RPX %RPX2 %HUNK1 %HNK2A %HUNK2 %HUNK3 %HNK4A %HUNK4
C00487 00125 HNKSZ0 HUNKSIZE HNKSZ1 HNKSZ3 HUNKP MHUNKE MAKHUNK MHUNK7 MHUNK6 MHUNK5 HUNK
C00490 00126 ALHNKL ALHNLA ALHNLD ALHNLY ALHNLX ALHUNK ALHNKD ALHNKF
C00494 00127 ATOM LATOM SPATOM SPAT1 PRPLSE PLIST PRPNIL RPLIZ SETPLIST RPSNIL STENT
C00496 00128 SASSQ SASSOC ASSOC ASSQ FALSE IASSOC IASSQ IASSC0 IASSC3 IASSC7 IASSCX IASSC4 IASLOS IASSQ0 IASSQF IASWIN
C00499 00129 GET BOUND1 GET3 GET0 GET1 SARGET ARGET ARGET1 PNGET PNGT1 PNGT0
C00501 00130 GETL GETLA GETL5 GETL1 GETL0 GETL1A GETL4
C00502 00131 PUTPROP CSET0C CSET0Q CSET0 CSET0A BRETJ SPROG2 CSET7 CSET2 CSET2A $CADR $CAR C$CAR CSET4 CSET4A
C00506 00132 REMPROP REMP0 REMP1 REMP20 REMP7 CSET4C REMP3 REMP3A
C00508 00133 NOTNOT NOT $NULL TRUE CNOT LAST LAST5 LAST4 LLASTCK LASTCK LAST1 LAST2 BOUNDP $RUNTIME RNTM1
C00512 00134 $TIME TIME3 TIME8 ZZZ ZZZ
C00516 00135 EQUAL EQUAL0 EQUAL1 EQLLST EQLTBL EQLNM4 EQLNM2 EQLNUM EQLOSE EQLBIG EQLHNK EQLHN1 EQLHN2
C00520 00136 NCONC APPEND APP2 APP3 .NCONC .NCNC1 .NCNC2 .NCNC3 .APPEND APP1 AR1RETJ SUBS4 REVERSE REV1 APRVCK REV4 NREVERSE NRECONC NREV1
C00523 00137 GENSYM GENSY0 GENSY2 GENSY3 GENSY1 GENSY7 GENSY6 GENSY5
C00525 00138 MEMBER SMEMBER SMEMQ MEMQ2 MEMQ3 MEMQ4 MEMBR MEMB2 MEMB3 AR2ARETJ MEMB4 SUBST SUBS0A SUBS1 CRETJ SPROG3 SUBS2 SUBS3
C00528 00139 DELQ DELETE DLT3 DLT2 DLT1 .DELQ .DELETE MEMQ MEMQ1
C00530 00140 NUMP TYPEP TYPNIL %SYMBOLP
C00531 00141 NMCK0 NUMCHK PDLNKJ PDLNMK PDLNM0 NMK1 PNMK2 CPDLNKJ
C00533 00142 GCPRO %GCPRO GCPR1 GCPR2 .GCPRO .GCPR5 GCPR3 GCPR4
C00536 00143 GCRL1 GCREL GCLOOK
C00537 00144 SXHASH ATMHSH BNHSH AHSH1 AHSH2 NILHSH SXHSH0
C00539 00145 SXHSH8 SXHSH7 SXHSH4 SYMHSH SXHSH5 SXHSH6 SXHSH9 SXHSD1 SXHSD2 SXHSC1 SXHSZ1 SXHS1A SXHS1B SXHS1F
C00542 00146 MAPATOMS MAPAT1 MAPAT2 MAPAT9
C00544 00147 MAPLIST MAPCAR $MAP MAPC MAPCON $MAPCAN MAPL0 MAPL1 MAPL1B
C00548 00148 MAPL3 CMAPL6 MAPL3A MAPL6 MAPL6A MAPL7 MAPL7A MAPL2 MAPL21 MAPL40 MAPL4 CMAPL3 MAPL22 MAPL23 MAPL24
C00552 00149 MAPL5 MAPL5A MAPL8 MAPL8B MAPL8C MAPL8A .MAP .MAP1 SET SETCK
C00555 00150 $BREAK $BRK0 CB CN.BB UDFB UBVB WTAB UGTB WNAB GCLB PDLB GCOB IOLB FACB BKCOM BKCOM0 BKCOM2 CBKCM0 BKCOM1
C00559 00151 INTERN INTRN3 INTRN1 INTRN INTRN4 MAKF MAKF1 MAK2 MAK4 MAK3
C00562 00152 MAKA3 MAKA3A MAKA0 MAKA MAKA2 MAKA5 MAKA4 MAK1
C00564 00153 RINTERN RINTN0 INTRN2 RINTN1
C00566 00154 IMPLODE MAKNAM CRINTERN MKNM1 MKNM2 RDL12 MKNM4 CHNV1X CHNV1 CHNV1D CHNV1A CHNV1B CHNV1C
C00568 00155 DEFPROP DEF1 DEF1B DEF9 DFPR2 DFPR1
C00570 00156 DEFUN DEF7 DEF3 DEF3B DEF3X DEF3L DEF3A DEF6 DEF5 DEF4
C00577 00157 TYIPEEK $$PEEK TYPK1 TYPK1C TYPK1F TYPK1H TYPK3 TYPK3C TYPK4 TYPK5 TYPK6 TYPK9 TYPK9A
C00581 00158 QUIT VALRET VALSTR VLRT2 VALS1 VALERR
C00584 00159 RETVAL RETSTR VLRT1 VLRT5 VLRT3 VLRT3A VLRT9 SIDDTP VLRT9
C00588 00160 SUSPEND SUSP0C SUSPGC SUSP0 SUSP0E SUSGC1 SUSP11 SUSP12 SUSP1 SUSP14 FLSNOT SUSP24 SUSP24 SUSP25 SUSP24 SUSP25 SUSP3
C00597 00161 SAVHGH SAPWIN
C00600 00162 ARGS ARGS1 ARGS1A ARGSCU ARGSC1 ARGS3 ARGS5 ARGS6 ARGCLB ARGCL3 ARGS0
C00603 00163 EVALFRAME FRM2A FRM3 FRM3A FRM4A FRM4 FRM5 FRM5A FRM7 FRM8 FRM2B
C00606 00164 GTPDLP GTPDL5 GTPDL2 GTPDL3 GTPDL4 GTP4A GTPX0 GTPX1
C00608 00165 FRETURN FRETRY FRETR1 FRP1 FRP2 FRP2A FRP4 FRP3 FRP3QA
C00612 00166 $GETCHARN GETCHAR GETCH1 GETCH2 GETCH3 GETCH4 GETCH8 GTCTB SUBLIS SUBLSA SUBL1 SUBL1B SUBL1A SUBLOSE SUBL3Q SUBL3Z
C00615 00167 SUBL2 SUBL3A SUBL3 SUBL4 SBL1 SBL5 SBL4 SBL2 SBL2A SBL2B
C00617 00168 SAMEPNAMEP ALPHALESSP ALPL3 ALPLP1 ALPL2 SYSP SYSP3 SYSP6 SYSPZ1 SYSPZ GCTWA GCTWI GCTWX
C00621 00169 COPYSYMBOL CPSY CPSY0 CPSY1
C00623 00170 SETSYNTAX RSSYN1 RSSYN2 RSSYN3 RSSYN5 RSSYN7 RSSYN8 CTRUE RSSYN4
C00625 00171 SSCHTRAN SSSYNTAX SSSYN1 GRCTI SMACRO SMCR1 GETMAC
C00628 00172 SSMACRO SSMC43 SSM4 SSM4AA SSM3 SMCR2 SSM1
C00631 00173 SSGCREL SSGCPRO SSGCP1 SSPROQ SSPROX SSGRL2 SSGRL1
C00633 00174 AUTOLOAD
C00634 00175 SYSCALL SCSL0 SCSL1 SCSL1A SCSL6 SCSL3 SCSL4 SCSL5 SCSTMA SCSFAI SCSXIT SCSXT1 SCSTAT STATER SSTATUS STATUS STAT1 STAT2 STAT3 STAT6 STAT6A STAT7 STAT8
C00642 00176 STSGVAL CQSSTATUS STSSVAL STSSV1 STSSTNIL STLOOK STLK1 STSCH STSCH1 STSCH2
C00644 00177 SNOFEATURE SFEATURE SSFEATURE SSFEA1 SSFEA2 SSNOFEATURE SSSSLU SSSSS SSSS SSSSS1 SARRAY
C00647 00178 SSPLSS SPLSS SCHTRAN SSYNTAX
C00648 00179 STTY STTY1 ZZZ STTY3 STTY4 ZZZ ZZZ
C00652 00180 SSTTY SSTTY1 SSTTY3 SSTTY7 SSTTY3 SSTTY4 SSTTY5 SSTTY3 SSTTY4 SSTTY2 TTY2ST TTYSAC
C00659 00181 SFRET
C00660 00182 SUUOLINKS SUUOL1 SSUUOLINKS SSUUL1 SCLI SSCLI CLIVAR
C00664 00183 STIME SDATE STCVT SUNAME SUSERID SJNAME SSUBSYSTEM SJNUMBER SHOMEDIR SHSNAME SHSNA1 SHSNA2
C00667 00184 SHSNAME SDATE STIME STIM2 SSUBSYSTEM SDATE STIME STIM2 SSUBSYSTEM SJNAME SJNUMBER SUSERID SUSER1 SUNAME
C00671 00185 STIME STIME1 SDATE SDATIM SJNAME SSUBSYSTEM SUSERID SUNAME SJNUMBER
C00674 00186 SSLINMODE ZZX
C00676 00187 SDOW SDOWQX SDOW SDOWQX SDOW SDOWQX
C00678 00188 SABBREVIATE SSABBREVIATE SSABB1 SMEMFREE
C00679 00189 SSYST0 SSYSTEM SSYST7 SSYST1 SSYST3 SSYST5 SSYST4 SSYST6
C00681 00190 SSGCTIM SGCTIM SGCTM1 SLVRNO STTYREAD SLAP SLAP1 SSTTYREAD SSLAP SSLAP1
C00683 00191 SLINMODE STERPRI STERP1 SSTERPRI
C00684 00192 SCRFUN SCRFIL SLOSEF SSLOS0 SSLOSEF BPDLNKJ
C00685 00193 SJCL SJCL2 SJCL4 SDDTP SJCL SJCL1A SJCL1 SJCL2 SJCL4 SJCL3
C00688 00194 STTYTYPE STTYSIZE STTYS1 STTSZ9 SOSPEED SOSSP9
C00690 00195 STTYTYPE STTYSIZE STTYS1 D10TNM
C00693 00196 STTYTYPE STTYSIZE STTYS1
C00694 00197 STTYSCAN STSCN1 SSTTYSCAN SSTSC1 STTYCONS STCON1 SSTTYCONS SSTCO1 SSTC2 SSTC1
C00698 00198 STTYINT SSTTYINT SSTIN1 SSTIN2 SSTIN3 SSTIN4
C00701 00199 SPDLMAX SSPDLMAX SGCSIZE SSGCSIZE SGCMAX SSGCMAX SGCMIN SSGCMIN SPDLSIZE SPURSIZE SSPCSIZE SPDLROOM SSGP1 SSGP1A SSGP1C SSGP1D SSGP2A
C00704 00200 SSGPGT SSGPLZ SSGP3$ SSG3A1 SSGP3A SSGP3Z SSGP3Y SSGPPT SSGM1 SSGM2 SSGMRV SSGP4
C00707 00201 SSGS1 SSGX1 SSPM1 CSETP1 CSETNS CSETP2 CSETP3 CSETP7
C00710 00202 SRANDOM SRAND3 SSRAN0 SSRANDOM SSRAN3 SSRAN6 SSRAN8
C00712 00203 SSWHO1 SSWHO2 SSWHO3 SWHO1 SWHO1A SWHO2 SWHO3 SIXNUM
C00714 00204 SMAR SSMAR SSMAR5 SFTV SSFTV SFTVSIZE SSFTVSIZE SFTVTITLE SSGCWHO
C00716 00205 SITS SITS9
C00717 00206 STBA LSSTBA
C00720 00207 LSTBA
C00723 00208
C00725 00209 STBSS LSST
C00728 00210 STBS
C00731 00211
C00734 00212 CURSORPOS CRSRPS CRSR10 CRSFA5 CRSFAY CRSFA4 CRSFA2 CRSFAZ CRSRP8 CRSFA1 CRSRP0 CRSR20 CRSRP5 CRSRP7 CRSRP3 CRSR40 CRSRP4 CRSRP6 CRSRP9 ZZZ ZZZ CRSR11 CRSR12 CRSR13 CRSR14 CRSRP1 CRSRMP CRSRM1 CRSRN
C00741 00213 %%FUNCTION .FUNC4 .FUNC1 .FUNC2 .FUNC3 AEVAL
C00743 00214 ALIST ALST1
C00748 00215 ALST2 ALST3 ALST3A ALST4 ALST4A ALST4C ALST5 ALST5A AL5AB
C00751 00216 ALST7 ALST6 ALST6A ALST6B ALST7A AUNBIND AUNBN0 AUNBN1 AUNBN2 AUNBN3 AUNBN4 AUNBN5 AUNBN6 AUNBN7
C00754 00217 IAP4A APFNG CAUNBIND APLBL APLBL1
C00756 00218 LISTIFY LFY3 LFY1 PNPUT $PNGET $PNG.R $PNG3 $PNG3A $PNG4 $PNG.D $PNGX
C00759 00219 DEPOSIT EXAMINE MAKNUM MUNKAM
C00760 00220 $SLEEP ALARMCLOCK ALCK3 ALCK4 ALCK1 ALCK5 ALCK7 ALCK2 M30.
C00763 00221 REMOB REMOB2 REMOB7 REMOB3 REMOB4 REMOB1 ARG ARGXX ARG3 SETARG ARGCOM
C00765 00222 SBSYM VCLSYM VCSYM TLSYM TSYM PLSYM PSYM POF TOF PSYM1
C00768 00223 PSYMP PSYMQ PSYMX CPSYMX PSYMP1 PSYMSB FCN.B
C00771 00224 TOF1 POF1 PSYMVC PSVC1 PSVC2 PSVC3 PUFY
C00773 00225 ZZ PSMTB LPSMTB P. PL. VC. VCL. T. TL. SB. BB PSYMT PSYMT1 PSYMT2 PSYMT3 PSYMTT PSYMTL
C00777 00226 PPTBL1 PPTBL2 PPTBL6 PPTBL3 PPTBL4 PPTBL5 PPTBL7 PPTBL9 PPTBL8
C00780 00227 XPURIFY PURIFY FPURF2 IPUR1 IPUR2
C00784 00228 IPUR3A IPUR3 IPUR4 IPUR5 IPUR6A IPUR6 IPUR7 IPUR9
C00787 00229 RSXTB2 RCT0
C00791 00230 TLRCT ZZ
C00795 00231 .NOPOINT CTY TYOI CTYP TYO1C TYO1TB
C00798 00232 PRNARG PRNAR$ PRNAR0 PRNAR3 PRNAR7 PRNTTY PRNAR2 PRNAR4 PRNAR5 PRNAR6 PRNARA PRNAR8 PRNAR9 PNAGX CPNAGX
C00803 00233 MPFLOK MPFLO1 MPFLO3 MPFLO2 PRNARK PRNRK3 PRNRK1 PRNRK2 PRTSTO PRTSO1 PRTSTR PRTST1 PRTST2 PRTSTL
C00808 00234 TYO$ %TYO %TYO1 TYO $TYO TYOPR TYO1 TYO6 STRTYO TYO6A TYO6B TYO5 TYO2 TYO2A TYO2Z TYO2B TYO4 TYOARG
C00811 00235 TYOFA TYOFIL TYOF TYOFS1 TYOFS0 TYOF0D TYOF0E TYOF0G TYOF2 TYOFXL TYOFE
C00816 00236 TYOF3 TYOFBS TYOFTB TYOFLF TYOFFF TYOF7 TYOFCR
C00819 00237 TYOF4 TYOF6 TYOF4A TYOXCT C$ INTTYR TYOF5 TYOF5Y TYOF4C TYOF4J
C00823 00238 %TERPRI TRP$ TERPRI TERP1 ITERPRI PTYO PTYO1 PTYO3 PTYO2
C00826 00239 PRINT %PRINT $PRINT CTY1 CTY2 PRIN1B PRIN1 %PRIN1 %PR1 $PRIN1 %PR1A PRINC %PRINC %PRC $PRINC X X
C00829 00240 PR.PRC PR.ATR PR.NUM PR.NVB PR.EFC PR.NLS PRINTY PRINTF PRINTA PRINT3 PRINT4 PRINH6 PRIN7A PRIN8A
C00833 00241 PRINTY PRINTF APRINT PRINTA PRINT0 PRIN0A PRINT1 PRIN1Q PRINT2
C00836 00242 PRINT3 PRIN3A PRIN3F PRINT4 PRINT5 PRINT6 PRINT7 PRINH6 PRIN7A PRINT8 PRIN8A PRINT9
C00841 00243 PRINH0 PRINH2 PRHN2B PRINH3 PRHN3A PRHN3B
C00843 00244 PRINX PRIN1A PRIN1Z PRINA1 PRINA2 PRINA3 PRINA4 PRINX5 PRINL4
C00846 00245 PRNSR PRNJB PRNFL PRNF5 PRNF6 PRNJ2 PRNF1 PRNSTO PRNJ1 PRNSR1
C00850 00246 PRINSY PRINN PRINIL PRNN1 PRNN2A PRNN2B PRNN2C PRNN2 PRNN3 PRNN3A PRNN3B PRNN3C
C00854 00247 PRNN4 PRNN4A PRNN4B PRNN5 PRNN5A VBARPOPJ PRNN6 PRNN6A
C00856 00248 MAPNAME MAPNM1 MAPNM2 MAPNM3 PRINLP PLP1 PRINLQ
C00858 00249 PRINI PRI2D PRI2C PRI2Q PRI2A PRINI2 PRINI9 PRINI3 FP7A1 FP7B PRINI5 PRINI7 PRI.
C00861 00250 PRI2B PRI2B3 PROMAN PRINRM PRINR0 PRINR1 PRINR2 PRINR3 PRINR4 PRINR5 PRINR6 PRINR9
C00864 00251 PRINDB DFP0 PRINO FP0 FP0A FP0B FP1 FP3 FP3A FP3A1 FPX0
C00869 00252 FP3
C00871 00253 DFP3A DFP3A1 DFP3A2 DFP3A8 DFP3A9
C00874 00254 FP4 FP4A FP4E0 FP4E1 FP4E FP4E2 FP4E2A FP4B FP4B1
C00879 00255 PRINCX PRNCX2 PRNCX3 PRNCX4 PRINDX PRNDX2 PRNDX5
C00881 00256 PRINB PRINB0 PRINBQ PRINBZ PRBAB PRINB3 PNFBLP
C00883 00257 PRBFNA PRBFIN PRINBI PRINBJ PRBNUF PRINB4
C00885 00258 FLATSIZE FLAT4 FLAT3 FLAT2 CFLAT2 FLATC FLATC1 FLATC2 FLATC3 $EXPLODEC $$EXPLODEN EXPLY1 EXPLY2 EXPLY3 EXPLY4 EXPLY9
C00888 00259 EXPLODE EXPL4 EXPL1 EXPL3 EXPL6 EXPL2
C00889 00260 BAKTRACE BAKLIST BKTR0 BKTR3 BKTR2 BKTR1 BKTR2X
C00893 00261 BKTR1A BK1A2 BK1A4 BK1A1 BK1A1C BK1A3 BK1A1B
C00896 00262 BKTR1B BKTR1C BKTR1F BKT1B1 BKT1F1 BKT1F2 BKTR1H BKTR1E BKTR1D BKTR1G BKTR1I BKTRR3 BKTRR5 UREAD UREAD2 UREAD1 UREOF UCLOSE
C00901 00263 UAPPEND UWRITE UWRT0 UWRT1 UWRT2
C00904 00264 UFILE0 UFILE UFILE5 SCRUNIT CRUNIT
C00906 00265 UGREAT UGRT1 UPROBE UKILL
C00908 00266 TTSR TTSR1
C00910 00267 RSQUEEZE SQUEEZE SQZCHR SQOK SQNOTL SQNOTD SQ%$
C00913 00268 5BTWD $5BTWD 5BTWD0 5BTWD1 5BTWD9 UNSQOZ UNSQZ1 UNSQZ2 UNSQZ3
C00915 00269 GETDD0 GETDD1 PUTDDTSYM PUTDD0 PUTDD2 PUTDD4
C00918 00270 LAPSETUP LAP5HAK L5H1 L5H2 L5XIT L5ERSTP L5SPBND L5H3 L5MKUNBD L5INHIBIT L50.0P L5NILP LAPSMH LAPSM1 LAPST2 LSYMPUT FSLSTP FSLST2
C00923 00271 LSYMS LGSYMS LLSYMS ZZ LAPSIX ZZ LAPFIV LAP5P GETDDTSYM GETDDI LGTSPC PAGEBPORG PGBP4
C00927 00272 MAKUBE MAKUNBOUND MAKUN1
C00929 00273 $PURIFY FPURF0 FPURF7 FPURF1 FPUR1Q FPUR1A FPURF4 FPURF3
C00931 00274 IP0 IP7 IP7 IP1
C00934 00275 GOINIT GOINI7
C00936 00276 ZEROP MINUSP PLUSP ZMP MINUS MNSFX
C00938 00277 ADD1 SUB1 SUB11 A1S1FX A1S11 A1S1BG ABSOV
C00940 00278 COMPR DIFFA PLUSA TIMESA QUOA QUOOV QUOAK QUOAK2 QUOAK1
C00943 00279 T1 .QUO .TIMES .DIF .PLUS T21 QUOTIENT TIMES DIFFERENCE PLUS T22 T20 T24 T4 T7 T7A T7X T7X1 T7O ZFZCHK ZFZCH9
C00946 00280 T5 T6 T6A T3 T15 T14 T14EX2 T14E T14EX T14EX1 ABS
C00948 00281 REMAINDER REMAI2 FLOAT FIX4 FLOAT4 $IFIX FIX FIX25
C00951 00282 .GREAT .LESS LESSP GREATERP GTR1 GTR9 MIN MAX MXF MXS MAXFIN MAX923
C00953 00283 GRSUC2 GRSUC1 GRS923 GRSUCE GRSFIN GRSF1 GRFAIL GRSWF GRSWX
C00954 00284 ADD1 SUB1 REMAINDER MINUS ABS MINUSP PLUSP ZEROP
C00956 00285 $IFIX FIX FIX4 FLOAT FIXFLO FLOAT3
C00957 00286 MIN MAX MINMAX .GREAT .LESS LESSP GREATERP MNMX1 MNMX9 GRESS GRUSE
C00959 00287 .DIF DIFFERENCE DIF2 .QUO QUOTIENT QUO2 QUO3
C00961 00288 .TIMES TIMES QUO1 .PLUS PLUS DIF1 PLUS1 PLUS7 PLUS5 PLUS3A PLUS4 PLUS9 PLUS2 PLUS2A PLUS2V T7O0
C00963 00289 EXPT XPTLL XPT.X XPTLX XPTLX1 XPTLX2 XPTOV
C00966 00290 XPTXX0 XPTXX XPTXX5 XPTXX3 XPTXX4 2XPT 2BGXPT 2BGXP1
C00968 00291 XPTBL XPT.B XPTZX0 EXPT6B EXPT6C EXPT1A EXPT1 EXPT3 EXPT2 EXPT4 XPTBX XPTBX1
C00972 00292 XPTII XPTI$ XPTZL 1.0PJ XPTZL1 XPTZL2 XPTZX XPTZX1 XPTM1
C00974 00293 RANDOM RAND1 IRAND IRAND0 IRAND3 IRAND5 RNDM1 RNDM2 RNDM0 RNDM1A RNDM2A
C00976 00294 HAULONG .HAU 4HAU 3HAU1 1HAU 2HAU 3HAU
C00977 00295 HAIPART 0HAI 0HAI1 0HAI2 0HAI3 3HAI 3HAI1 3HAI2 3HAI3
C00980 00296 LNGTER LENGTH LNGTH0 LNG1A LNGTH1 LNGTE1 LNGTH2 LNGTH5 LNGTH6 BIGP
C00982 00297 BOOLE BOOLL BOOLG BOOL1 ODDP1 ODDP ODDP2 ODDP21 ODDP4 ODDP3
C00984 00298 $FSC $ROT $LSH SHIFTY .GCD .GCD0 .GCD3 .GCD1 .GCD2 GCD0 GCD GCDXX
C00987 00299 $EQUAL $EQL1 $IEQ IEQUAL $LESS $GREAT $IGL1 $IGL IGRT IADD1 $ADD1 ISUB1 $SUB1
C00989 00300 $ARITH IARITH I$B I$ART2 ARITH IARDS ARIT0
C00991 00301 IDIFFERENCE IPLUS IQUOTIENT ITIMES $DIFFERENCE $PLUS $QUOTIENT $TIMES IARZAR
C00992 00302 $SIN SIN. SIN.0 SIN.1 SIN.2 SIN.XT PI%2 SIN.CF COS COS.
C00996 00303 SQRT SQRT. SQRT.. SQRT.1
C00997 00304 SQRT SQRT. SQRT..
C01002 00305 SQRT SQRT. SQRT.. SQRT.2 SQRT.3
C01005 00306 LOG LOG. LOG.. LOG.1 LOG.2 ROOT2 LOG.CF NUMFLT NUMFL3
C01007 00307 ATAN ATAN. ATAN.1 ATAN.2 ATAN.3 ATAN.4 PI% ATAN.C
C01010 00308 EXP EXP. EXP.. EXP.A EXP.1 EXP.2 EXP.RX EXP.3 EXP.CF FPWUN INTLG C1.0E5 YPOCB BCOPY BCOP1 BNARSV BNARRS
C01015 00309 PLOV PLOV2 PL1BN TIMOV TIM1BN T2 T12 PL2BN
C01017 00310 TIM2BN T11 T13 T13X BNDF BNPL BNPL1 T19A T19B T19C BNXTIM BNTIM
C01019 00311 DIVSEZ REM2BN DV2BN DV1BN BNDV
C01021 00312 DV2BN1 DV2BN2 BNFXLP DV2BN3 D1FIN
C01023 00313 BNTRUN BNTR4 BNTRSZ BNTRS1 BNPJ2 BNCV BNCVTM T17 T16 T23
C01026 00314 BNSUB BNADD BN4 BN15 BN20 BN7 BN9 BNADD2 BN14 BN8 BN5 BN13 BN6
C01028 00315 BNSUB2 BN10 BN11 BN11A BN12 BNM1 BNM2
C01032 00316 BNMUL BNM5 BNM4 BNM3
C01035 00317 BNQUO BNQUO1 BQ1 BQ2
C01037 00318 BQCC BQGEST BQZQ BQCOPY BQNORM
C01039 00319 BQ6 BQSRRM BQSHRM BQVET BQSHRT REMFIN BQ10 BQDD BQ11
C01041 00320 BQ5 BQ7 BQ8 BQ9 BQ9A BQ9B
C01043 00321 BQEFIN BQSH0 BQ1DF BQGESS BQCHEK BQC2 BQC1 BQFIN
C01045 00322 BQSUB BQSUB0 BQSUB7 BQSUB1 BQSUB6
C01047 00323 BQSUB3 BQSUB4
C01050 00324 FLBIGF FLBIG FLBIGX FLBIGZ FLTB1 FLBIGQ FLBIGO
C01052 00325 FIXBIG FXBFV FXBFZ FBFIN FXBFQ MNSBG 4CHKRT
C01054 00326 ABSBG0 ABSBG REMBIG GRBB GRBBL GRBR
C01056 00327 GRFXB GRBFX GRBF GRB1 GRB12 GRB13 GRB14 GRB2 GRBBEL GRBBE2
C01058 00328 1HAI 1HAI1 2HAI 2HAI2 2HAI0 2HAI3 2HAI4
C01061 00329 GCDBG GCDBG0 GCDBG1 GCDBG2 GCDBGU GCDBHU GCDBG4
C01065 00330 GCDBGV GCDBHV BNLWFL BNLWFX BNLWXX GCDBGO GCDBGT GCDBX GCDOV GCDOV1
C01067 00331 POP3UB POP2UB EVALHOOK EVNH3 EVNH0 OEVAL OEVL1 EVAL EVAL0
C01070 00332 EV0 EV0A EVTB1 EV2 EVTB2
C01073 00333 EE1 EE2 EE2A ETT EAL EAL2 EFM EFMER
C01075 00334 EFX AEXP EXP3 CIAPPLY EFS ELSB ELSB1 ESAR EAR EAR3 EAR1
C01077 00335 ESB ESB4 ESB2 ESB1 ESB3 ESB3A ESB3C EV3 EV4 EV4B EWHEN
C01080 00336 SYMEV0 SYMEVAL EVSYM EE1A
C01081 00337 APPLY APPWT1 .APPLY AP3 AP3A APPWTA AP2 AP4
C01084 00338 SUBRCALL RETTYP %LSUBRCALL PTRCHK
C01085 00339 %ARRAYCALL %ARR7 FUNCALL FUNCA1
C01087 00340 IAPPLY ILP1 ILP1B
C01090 00341 APTB1 IAPATM IAPAT2 IAPAT3 IATT IAPIAL IAPIA1 IIAL IAPSAR IAPARR IAPSBR IAPSB1 IAPAR1
C01093 00342 IAPXPR IAPLSB IAP2
C01094 00343 IAPLMB IPLMB1 IAP5 IAP5C IAP5B IPLMB2 IPLMB4 IPLM4A IPLM4B IPLMB5 LMBLP LMBLP1 LMBLP2 IPROGN IAP3 CUNBIN IAP4
C01098 00344 FUNCTION QUOTE DECLARE $COMMENT SETQ SET1 $AND $OR ANDOR
C01100 00345 PROG PRG1 PRG1Z PG0 LPRP PG1 PG1A PG0A VBIND PBIND PBIND1 PBIND2 PROGV RETURN PRXIT ERRP4 RHAPJ CQFUNCTION
C01104 00346 GO GO2 GO1 PG5 PG5A GO3 GO3B GO3A
C01106 00347 DO DO4A DO4 DO4C DO7 DO7A DO9
C01108 00348 DO8 DO2 DO4D DO5 DO5Q DO5Q1 DO5F DO5B
C01110 00349 DO5E DO5D DO5G DO5C DO6 DO6A DO6C
C01112 00350 COND1 COND CON3 COND2 CON2 BKERST BKRST3 BKRST4 BKRST0 BKRST2 BKRST1
C01115 00351 ERRSET ERRST3 ERRNX ERR ERR3A ERR3 CATCH .CATCH .CATC1 CATCHB CATCB2 CATCB1 CATCHALL UNWINP UNWERR PTNTRY UNWINC PTEXIT UNWINE THROW .THROW CATHRO
C01122 00352 CASEQ CASEE CASEF CASES CASE1 CASE1E CASE1H CASE1D CASE1B CASE1A CASE1Z CASE1G CASE1Q CASEBQ CASEBZ CASEM CASECK CASEEQ CASEAQ CASE1C IF IF1A
C01128 00353 $PUSH $PUSH2 $PUSH1 $POP $POP4 $POP5 $POP2 $POP1 $POP3 DISPL0 DISPLACE DISPL2 DISPL1
C01133 00354 STORE STORE7 STORE9 BREAK SIGNP SIGNP0 SPTB
C01136 00355 PROG2 PROGN PROGN1 EQ RPLACA RPLACD RPLCD3 RPLCD2
C01138 00356 GCRET GCNRT GC MINCEL GCCNT GCCNT1 GCCNT4 LPROG3 GCCNT0 GCCNT1 GCCNT6 GCCNT0
C01141 00357 WHL AGC4 AGC AGC1 AGC1Q GCP4 GCP4A GCP4B
C01146 00358 GCP5 GSTRT0 GSTR0A GSTRT1 GSTRT2 GSTRT3 GSTRT5 GSTRT7 GSTRT8 GSTRT6 GCWHL2 GCWHL3 GCWHL9
C01150 00359 GCP6 GCP6Q0 GCP6Q1 GCP6Q2 GCP6Q3 GCP6Q4 GCP6Q5 GCP6Q6 GCP6Q8 GCP6Q9 GCP6R0
C01153 00360 GCP6B1 GCP6B2 GCP6A GCP6F1 GCP6F GCP6F0 GCP6D GCP6D1 GSTRT9 GCWHL6
C01156 00361 CGCMKL GCP6H GCP6H1 GCP6H8 GCP6H3 GCP6H4 GCP6H5 GCP6G GCP6H0
C01158 00362 GCP6H7 GCP6H2 GCP6H9 GCP6J1 GCP6J3 GCP6J9
C01161 00363 GCP7
C01162 00364 GCSWP GCSW1 GCSW2 GCSW2A GCSW5 GCSW7
C01165 00365 GCSWTB GCSW7A
C01167 00366 GCSWS GCFSSWP GFSP1 GFSP2 GFSP4 GFSP5 GCSWY GSYMSWP GYSP1 GYSP2 GYCNT GYSP3 GYSP5 GYSP5A GYSP5B
C01171 00367 GCSWD GCSWC GCSWZ GCSWH1 GCHSW1 GH1SP1 GH1SP2 GHCNT1 GH1SP4 GH1SP5 GH1SP6 GH1SP4
C01174 00368 GCSWH2 GCHSW2 GH2SP1 GHCNT2 GH2SP5 GH2SP7 GH2SP5 GCSWA GSARSWP GSSP0 GSSP1 GSSP2
C01177 00369 GCPNT GCPNT1 GCPNT2 GCPNT6
C01178 00370 GCE0 GCE0C0 GCE0C1 GCE0C5 GCE0C2 GCE0C3 GCE0C9 GCE0C6 GCE0K3 GCE0C7 GCE0C4 GCE0K2 GCE0K1
C01181 00371 GCE0E
C01183 00372 GCEND GCRSR0
C01186 00373 GCINBT GCINB0 GCWHR GCWHR8 GCWHR2 GCWHR9
C01189 00374 GCACRS GCACR $GCMKAR GCMKAR GCMKA1 GCGEN GCP8A GCP8A1
C01192 00375 GCMARK GCMRK0 GCMRK3 GCMRK6 GCMRK7 GCMRK4 GCMRK5 GCMKND GCMRK8 GCMRK1 GCMRK2 GCMK2A GCMK2B GCHNLN
C01198 00376 LSPGCM LSPGCS KLGCVC KLGCM1 KLGCND KLGCM2 KLGCSY KLGCSA ZZZ ZZZ KLGCSW KLGS1 KLGS1A KLGS1D
C01201 00377 GSGEN RTSPC2 RTSP2A GGEN2 GGEN1 GFSPC GTSP5A BPSGC BPSGX
C01203 00378 GCP8K GCP8J GCP8I GCP8G GCP8C GCP8B GCP8D GCP8H GCP8L GCP8L5 TWAP
C01206 00379 STGPNT GCBT
C01208 00380 RETSP RTSP2 RTSP7 RTSP9 RTSP5 RTSPC1
C01213 00381 GTSPC1 GTSP1B GTSPC8 GTSPC2 GRELAR GREL1 CZECHI GTSPC8
C01217 00382 CNLAC BPNDST GTSPC3 GT3Z GT3H GT3B GT3A GT3C GT3D GT3D2 GT3G
C01222 00383 PURCOPY PCOPY9 PCOPLS PCONS PCOPFX PFXCONS PFXC1 PFXC3
C01225 00384 PCOPFL PFLCONS PCOPCX PCXCONS PCOPDB PDBCONS PDBC3 PCOPDX PDXCONS PCOPBN PBNCONS
C01228 00385 PCOPSY PCOPS1 PCOPS3 PCOPHN PCOPH3
C01232 00386 GETCOR GTCOR4 GTCOR6 LHVB0 LHVBAR LHVB3 LHVB4 LHVB1
C01235 00387 PDLST0 PDLST8
C01238 00388 PDLOV PDLH0A PDLH2 PDLH2A PDLH2B PDLH3A PDLH4
C01242 00389 MORPDL PDLMSG PDLST9 PDLH5 PDLH6
C01244 00390 GRBPSG GTNPSG GTNPS8
C01248 00391 GTNPS3
C01251 00392 GCGRAB GCGRB1
C01253 00393 GRBSEG GRBSG1 GCWORRY GRABWORRY GCWR0A GCWR0B GCWOR2 GCWR2A GCWR2B
C01258 00394 GCWR2C GCWR3A GCWR3B GCWR3F GCWOR4 GCWR4Q GCWOR6 GCWOR7
C01262 00395 GCWORG GCWORS GCWFOO GCWORX GCWRX1 GCWRX2 LPROG9 GCWORN
C01265 00396 ALIMPG ALIMP3
C01268 00397 RECLAIM RECL1 RECL2 RECLFW REBIG RECL9 RECL9A
C01271 00398 MAKVC3 MAKVC4 MAKVC8
C01274 00399 LDPRG9 ARGCL7 MAKVC9 MAKVC5 MAKVC6
C01276 00400 $ALLOC $ALLC6 $ALLC9 $ALLC7 $ALLC8 $ALLC4
C01278 00401 $ALLC0 $ALLC5 $ALLC3 $ALLC2 RS.FF RS.VMO RS.SQX RS.BRK RS.SCO RS.WSP RS.DOT RS.MAC RS.SLS RS.RBO RS.SL1 RS.PNT RS.SL9 RS.ALT RS.ARR RS.SGN RS.DIG RS.XLT RS.LTR NWTNE NWTNN RS.FF RS.VMO RS.SQX RS.BRK RS.SCO RS.WSP RS.LP RS.DOT RS.RP RS.MAC RS.SLS RS.RBO RS.SL1 RS.PNT RS.SL9 RS.ALT RS.ARR RS.SGN RS.DIG RS.XLT RS.LTR NWTNE NWTNN RS.CMS RS.SCS RS.OBB RS.WTH RS.SEE
C01284 00402 $READCH RDCH$ READCH RDCH3 $ASCII RDCH2
C01285 00403 XINCALL INCAST INCSEO XINCA1 INCALL INCAL4 INCST2 INCST3 INCST4 INCAL5 INCAL1 INCALZ INBIND INBN4 INBN1 INBN9 LINBN9 INCAL2 INCST1 INCAL7 EOFBN0 EOFBIND EOFBN3 EOFBN5 CEOFBN5
C01293 00404 EOF EOF2 EOF8 EOF1 EOF7 EOF4 EOF9 EOF5 EOFZ
C01295 00405 INPU0 INPUSH INPU1 INPU12 INPU2 INPU3 INPOP INPU5 INPU6 INPU7 INPU8
C01297 00406 TYI$ %TYI TYI UNTYI UNTYI3 SUNTYI
C01300 00407 $PEEK $DEVICE $DEV0 $DEVP1 $DEVP2 $DEVPE $DEV0Z $DEV0B $DEV1 $DVLUZ $DEV2 $DEV2B $DEV2D $DEV2E $DEV2P $DEV4Q $DEV4 TYIXCT $DEV4B TYIXCT TYIXCT $DEVS4 $DEV4S $DEV4U $DEV4Z $DEV4A $DEV4D $DEV4H $DEV4H TYICAL $DEV4K $DEV4M $DEV5F $DEV5 $DEV6 $DEV6A $DEV6B $DEV7 $DEV5K TYICA1 $DEV5M $DEVER INFGT0 INFGET INFLZZ INFLUZ
C01317 00408 BYTEAC MKNR6C MKR6DB
C01318 00409 READLIST RDLPEK RDLTYI RDLTY1 RDLTY3 RDLTY9 RDLTY2 RDLPK1 RDLUNTYI READ6C R6C1
C01320 00410 READ$ IREAD IREAD1 OREAD READ READ0
C01322 00411 READ0B RD0B1 RD0B2A RD0BRM RVRCT
C01324 00412 READ0A RMCER REKRD REKRD1 RDOBJ3 RDOBJ1 RDOBJ RDOBJ0
C01327 00413 RDJ2A RDOBJ5 RDOBJ2 RDJ2A1 RDOBJ6 RDJ6A RDOBJ7 ER1 RDOBJ4 RD8W RD8N
C01329 00414 RDNUM RDNUM2 RDNM10 RDNUM1 RDNUM8 RDNUM7 RDNUM9 RDNM9E RDNM9B RDNM9C
C01332 00415 RDNUM0 RDNUM6 RDNM8A RDNMF RDNM2 RDNM2A RDFXNM RDFX1 RDFL1
C01334 00416 RDNUM5 RDNUMD RDNUMB RDIBOV RD10OV RDNUMC
C01336 00417 RDFXEX RX1 RX1 RDFX2
C01337 00418 RDFLNM RDFL3 RDFL3A RDFL2A RDFL2D RDL2D0 RDL2D3 RDL2D1 RDFL2E RDL2E0 RDL2E1 RDL2A0 RDL2A2 RDL2A1 RDL2A3
C01340 00419 RDLST RDLSTA RDLSAA RDHNK1 RDLST1 RDLST0 RDLST3 RDLSX RDLSX1 RDLS3D RDLST4 RDLS4A RDLS4B RDHNK RDSKWH
C01345 00420 RDOBJM RDALPH RDA0 RDA1 RDA3 RDA4 RLAST RLAST1 RDCHO1 RDCHO4 RDCHO3 RDCHO RDCHO2
C01348 00421 RD10OV RDIBOV RDBG10 RDBG1A RDBGIB RDBGIA .RDMULP .TIMER .TM.PL
C01350 00422 RDRGSV RDRGRS RDEXOF RDEX3 RDBIGN RDBIGM
C01352 00423 RDBGEX RDBGXM RDBFSH RDBXFL RDCBG RDCBG1 RDNM2B
C01354 00424 RDCHAR RDCH1 RDBK RDNMX RDNUM4 RDNM4A
C01356 00425 RDROM RDROM1 RDROM2 RDROM3 RDROM7 RDAEND IRDA IRDA1 RDIN
C01358 00426 RDQTE RDSEMI RDSMI0 RDSMI1 RDVBAR RDVB2 RDVB3 RDVB4 CTRLQ CTRLS
C01361 00427 %TXMTA %TXCTL %TXASC TTYBUF TTYB0 TTYB1 TTYB1E TTYB7 TTYB7E TTYB7G TTYB7F TTYB7H TTYB7N CLRSRN TTYB2 TTYB3 TTYB3A TTYB4 TTYB4C TTYB4G TTYB4J TTYB4M TTYB5 TTYB5H TTYB5K TTYB5M TTYB6 TTYB6C TTYB6F TTYB6J TTYB6Q TTYB9 TTYB9A TTYB9B TTYB9D TTYB9J TTYB8
C01371 00428 RCPOS TTYBRC TTYBR1 TTYPSH TTYPS1 TTYATM TTYBCH TTYBLT TTYBL4 TTYBL1 TTYBL2
C01375 00429 RUBOUT RUB1CH RSTCUR RSTCU3 RUB1C1 RUB1C3
C01379 00430 %READLINE %RDLN5 %RDLN6 %RDLNZ
C01381 00431
C01384 00432 ARYTP1 NPARTP LARYTP ARYTYP ARYIN1 ARYIN2
C01388 00433 DIMSTB DIMFTB DIMDTB DIMZTB
C01390 00434 TTDEAD TTDEDC ARRAY %%ARRAY ARRY0 ARRY0B ARRY0C ARRY0F ARRY0G ARRY1 ARRY1A
C01393 00435 ARRYQ0 ARRYQ1 ARRYQ2 ARRYQ3 ARRYQ4 ARRYQ5 ARRY1D ARRY1F ARRY2 ARRY2A ARRY2B
C01395 00436 ARRY2C ARRYAE ARRY2F ARRY2H
C01398 00437 ARRY3A ARRY6 ARRY6Q ARRY6A
C01400 00438 ARRY7 ARRY7A ARRY7B ARRY4 ARRY5 ARRY5D ARRY5F ARRY5G ARRY8
C01405 00439 AREGET AREGT2 AREGT0 AREGT1
C01406 00440 MKFLAR MKFXAR MKDTAR MKLSAR MKAR1 SACONS ADIMS0 ADIMS ADIMS1
C01409 00441 BLTARRAY BLTAR1 BLTXIT BLTALZ BLTALS
C01411 00442 .REA3 .REA3C .REA3D .REA3E C.REA2 ARYSIZ ARYSZ3 ARYSZ4 ARYSZ6 ARYSZ5 ARYSZ7
C01415 00443 OBAFIX OBAFX1 OBAFX3 RDTFIX RDTFX2
C01417 00444 BLTO1 BLTO3 BLTO4
C01421 00445 BLTI1 BLTI4 BLTI3 BLTI5 BLTI6 BLTI8
C01427 00446 .REARRAY .REA4B .REA4A .REA4 .REA5 .REA6 .REA6A .REA7 .REA7A .REA2 .REALOSE GETSP GETSP0 AGTSPC GETSP1 .REA1 .REA1A
C01432 00447 AYNV1 AYNV5 AYNV4 AYNV3 AYNV2 AYNV0 AYNVER AYNVE1 2DIMS 2DIMS1 2DIMF 2DIMF1 2DIMD 2DIMD1 2DIMZ 2DIMZ1
C01436 00448 3DIMF 3DIMS 3DIMX 4DIMF 4DIMS 5DIMF 5DIMS
C01439 00449 FILLARRAY FILLA0 FILLA1 FILLA4 FILLA5 FILLA2 FILLA3 FILLD1 FILLD3 FILLD6 FILLZ1 FILLZ3 FILLZ6 OPNCLR FILLA6 FILLA9 FILLA8 FILLA7 FILLUZ
C01444 00450 LISTARRAY LISTA3 LISTAZ LISTA7 LISTA1 LISTA2 LISTA5 LISTA6 LISJOB LISFIL LISTD5 LISTD6 LISTZ5 LISTZ6 LLDAT ILDAT LLDSTB LDAGEN LDPRLS LDDDTP LDBGEN LDNPDS
C01452 00451
C01467 00452 IALB
C01468 00453 FASLOAD LDXXY1
C01470 00454 LDDISM LDRTHS LDXQQ5 LDXQQ2 LDXQQ3 LDXQQ6 LDXQQ8 LDXQQ7
C01476 00455 LDXXX1 LDXXX9
C01478 00456 LDXHHK LDXHAK LDXHK1 LDXHK2 LDXHK3 LDXHK5
C01482 00457 LDXHAK LDXFLC LDXIRL LDREL LDABS LDABS1 LDABS0 LDBIN LDBIN1 LDBIN2 LDTTBL
C01487 00458 LDGTSP LDGS0A LDGS0H LDGSP1 LDGSP3 LDGSP5 LDGSP4 LDGSP6
C01490 00459 LDSPC LDSPC1 LDQAT
C01493 00460 LDQLS LDQLS3 LDQLS1 LDQLS2 LDQLS5 LDQLS4 LDQLPRO LDGPRO
C01496 00461 LDPRC LDPRC1 PRCHAK LDPRC2 LDPRC3 LDPRC4 LDPRC5 LDPRC6 LDPRC7
C01500 00462 PRCHAK PRCSMS PRCHA1 PRCH1A PRCH1B PRCHA4 PRCHA3 PRCHA2 PRCH2A PRTRTS
C01506 00463 LDSMSH LDZA2 LDZAOK LDZA1 LDSMNS
C01510 00464 LDGET LDGET1 LDGET2 LDGT5A LDGET4 LDGT5B
C01513 00465 LDGETX LDGETJ LDGETV LDGETW LDGET6 LDGDDT LDGDDT LDGDDT LDXCT LDMASK LDLHRL
C01516 00466 LDAREF LDARE1 LDGLB LDATM LDATBL LDATPN LDATP1 LDATP2 LDATP3 LDATP4 LDATP8
C01519 00467 LDATFX LDATX0 LDATX1 LDATX2 LDATX3 LDATFL LDATL0 LDATL1 LDATL2 LDATL3
C01521 00468 LDATBN LDATB1 LDATB2 LDATB3 LDATB6 LDATB7 LDAEXT LDRFRF
C01523 00469 LDENT LDENT4 LDNRDF LDPARG LDPRG3
C01527 00470 LDPUT LDPUT7 LDPUT0 LDPUT4 LDPUT5 LDPUTM
C01530 00471 LDPUT LDPUT7 LDPUT0 LDPUT1 LDPUT2 LDPT2A LDPT2B LDPUT3 LDLOC LDLOC5
C01533 00472 LDEVAL LDEVL7 LDEV0 LDEV4 LDEV5 LDEV2 LDEV1
C01536 00473 LDBEND LDBEN1 LDFEND LDFEN2 LDFEN3 LDNPUR LDZPUR
C01538 00474 LDGCPR LDGCP1
C01540 00475 LDSDPL LDSDP1 LDSDP2 LDSDP3
C01541 00476 LDEOMM LDEOM1 LDTRYI LDLRSP LDRSPT
C01543 00477 LDLIST LDLIS0 LDLIS1 LDLTBL LDLATM LDLLST LDLDLS LDLLS1 LDLLS3 LDOWL LDLHNK LDLEND
C01546 00478 ZZ ZZZ ZZ ZZZ LDFNM2 LDGTW0 LDGTWD LDGTW1 LDGTW9 LDGTW0 LDGTWD LDGTW1 LDGTE1 LDGTWE LDGTW0 LDGTWD LDGTW1 ALCHAN ALCHN0 ALCHN1 ALCH1A ALCHN2 ALCHN3 ALCHN9
C01555 00479 ALFILE UNLKPJ
C01558 00480 AFILEP XFILEP FILEP AFOSP XFOSP
C01560 00481 OFILOK IFILOK ATFLOK ATOFOK ATIFOK TFILOK TIFLOK TOFLOK XIFLOK XOFLOK FILOK NFILE FILOK0 FILOK1 FILNOK
C01563 00482 NML6BT NML6B5 NML6BZ NML6B0 NML6B2 NML6FN NML6UF NML6F5 NML6F2 NML6F4 NML6F3 NML6DV NML6PP NML6P2 NML6D1 NML6D8 NML6D7 NML6D4 NML6P1 NML6P3 SARGHT IDND IDND IDNTB LIDNTB IDND IDND1 IDND2 IDND3 IDNDLS
C01587 00483 NAMELIST 6BTNML 6BTNL3 6BTNL4
C01590 00484 SHORTNAMESTRING NAMESTRING 6BTNMS X6BTNSL 6BTNSL 6BTNS 6BNS0A 6BTNS0 6BNS4A 6BTNS4 6BTNS5 6BTNS8 6BTNS1 6BTNS2 6BTNS3 6BTNS2 6BTNS3 6BTNS6 6BNS6A 6BNS7A 6BTNS7 6BNS7B
C01600 00485 NMS NMS.CQ NMS.CA NMS.DV NMS.FN NMS.DT NMS.XT NMS.LB NMS.CM NMS.RB NMS.ND NMS.ST NMS6BF NMS6B0 NMS6BT NMS6B1 NMS6B8 NMS6B6 NMS6B5 NMS6B7 NMS6B9 NMS6B4 NMS6BQ NMS6BL NMS6DV NMS6SN NMS6PD NMS6LB NMS6L1 NMS6CM NMS6RB NMS6R2 NMS6R1 NMS6ST NMS6PP
C01614 00486 NMS6BB NMS6BA NMS6B0 NMS6BT JFN6BT JFN6BX JFN6BZ JFN6BY JFN6ER LFGB20 LFGB10
C01619 00487 IFL6BT FILSFA FIL6BT FIL6B0 FIL6DF FIL6B1 FIL6B2 QIOSAV LQIOSV
C01622 00488 MERGEF MRGF1 DMRGF ZZZ ZZZ DMRGF5 IMRGF MRGF2 C6BTNML TRUENAME TRUNMZ TRU6BT TRUNM2 TRUNM8 TRUNM9 TRUNM0 SUREAD SUWRITE
C01629 00489 2MERGE PROBEF PROBEZ PROBF0 D10RFN PROBF6 PROBF8 PROBF9
C01635 00490 $RENAMEF RENAM1 RENAM0 RENM0A RENM0B RENM1A RENAM2 RENM2A RENAM7 RENAM8 RENAM4 RENAM5 RNAM5A RENAM4 RENAM5 RENAM6 RENAM9 XCIOL RFNAME CNAMEF CNAME3 CNAME2 CNAME1 CNAMER CNAER1 CNAER2
C01644 00491 $DELETEF $DELNS $DEL6 $DEL3 $DEL7 $DEL5 $DEL4 $DEL5 $DEL9 $DEL9A
C01649 00492 CLOSE0 $CLOSE ICLOSE ICLOS6 CLOSE9 JCLOSE CLOSE4
C01652 00493 FORCE FORSF1 FORCE1 FORCE9 IFORCE IFORC1 FORCE6 IOTTTT SIOT
C01656 00494 SFMD0 SFILEMODE SFMD0A SFMD1
C01660 00495 LOAD LOAD5 LOAD6 LOAD7 LOAD7A LOAD8 LOAD1 LOAD3 LOAD2 LOAD4 $FASLP FASLP1 FASLP2 FASLP8 FASLP9 FASLP2 INCLUDE INCLU1 INCEOF
C01669 00496
C01674 00497 $OPEN $OPNNS OPEN0J OPEN1A OPEN1C OPN1F1 OPEN1F OPEN1G OPEN1K OPEN1H OPEN1Z
C01678 00498 OPMDS LOPMDS OPBITS
C01680 00499 OPEN1L OPEN1Y OPEN1S OPEN1M OPEN1N OPEN1P OPEN1R OPEN1Q
C01687 00500 OPEN1T
C01690 00501 OPEN3 OPEN3C SOPEN3C OPEN3D OPN3D1 OPEN3E OPEN3F OPEN3M OPEN3N OPEN3D OPEN3E
C01700 00502 OPEN3G OPEN3P OPEN3K OPEN3J OPN3LA OPEN3L OPN3LB OPEN3Q OPEN3H OPEN3V OPEN3Z
C01708 00503 OPNBO1 OPNAO1 OPNBI1 OPNAI1 OPNA6 OPNTI1
C01711 00504 OPNTO1 OPNTO5
C01714 00505 TTYGET TTYSET SCML CNSGET OPNAT3 OPNAT5 OPEN4
C01716 00506 OPNALZ OPENLZ OPNLZ0 OPNLZ3 OPNLZ2 OPNAND OPNLZ1 OPNLZS OPNLZR
C01718 00507 OPENUP FILLEN ACCESS RCHST
C01720 00508 OPEN9A OPEN9B OPEN9D
C01723 00509 OPEN9C $EOPEN $EOPN1 $EOPN2 $EOPN3 $EOPN6 $EOPN5 $EOPN7 $EOPN8 $EOPN9 $EOPN4
C01730 00510 DEFAULTF SSCRFILE ENDPAGEFN EOFFN EOFFN0 EOFFNZ EOFFN2 EOFFN5 EOFFNY EOFFN7
C01733 00511 $LISTEN $LSTN3 $LSTNS $LSTN4 $LSTN6 $LSTN5 LISTEN
C01736 00512 LINEL PAGEL CHARPOS LINENUM PAGENUM FLFWNA FLNSFL FLFROB FLFRFL FLFRF1 FLFRB1 FLFB1A FLFRB3 FLFRB5 FLFRB6 FLFRB8 FLFRB7
C01740 00513 $IN $INNOS $IN2 $IN1 $IN3 $IN4 $IN7 $IN8 INSIOT
C01746 00514 $OUT $OUTNS $OUT3 $OUT2 $OUT1
C01749 00515 FILEPOS FPOS0E FPOS0B FPOS0C FPOS0D FPOS0 FPOS0A FPOS1 FP1SF1 FPOS1A FPOS1C FPOS2
C01752 00516 FPOS5 FP5SF1 FPOS5A FPOS6 FPOSZ FPOS6C FPOS6B FPOS6A FPOS7 $LENWT $LENGTHF $LENFL
C01760 00517 CNPCOD CNPCUR CNPCD1 CNPCD2 CNPC9 VAROPT CNPOK
C01766 00518 CNP.X CNP.B CNP.M CNP.C CNP.T CNP.IL CNP.DL CNP.A CNP.D CNP.F CNP.H CNP.H1 CNP.I CNP.Z CNP.U CNP.V CNPBBL CNPBL CNPL CNPU CNPF CLRSRN CLRSRN
C01770 00519 OPNTTY OPNT0 OPNT1 OPNT1A OPNT2 COPNT2
C01774 00520 CLRIN CLRI3 CLRIN9
C01776 00521 CLROUT CLRO3 CLRO4 CLRO4 RCPOS1
C01778 00522 TTYMOR TTYMO3 TTYMO1 TTYMO2 TTYMOZ
C01780 00523 STCREA STCREN STMASK STCRE4 STCRE5 STCRE6 STCRE3 STCRE2 SCREBS STCRE1 STKNOT STKNOL STCAL1 STCALL ISTCAL ISTCA0 ISTCSH ISTCA1 ISTCA2 STPRED STSTOR STGET STDISW STDIOB STDIS1 STDIS2 STSYSL STRSLN STGETD STGETU STGPNA STGFUN STGWOM STGWO1 STGWO2 STSTOD STSTOU STSTU1 STSPNA STSFUN STSWO1 STSWOM
C01794 00524
C01795 00525 PIHOLD PINBL STDMSK DBGMSK STDMS2 DBGMS2 INTVEC TTYDF1 TTYDF2 LINTVEC
C01799 00526 DISMSK DISMSK STDMSK STDMSK STDMSK DBGMSK CHNTAB LEVTAB ENBINT ENBIN2 ENBIN1 REAINT DALINT DISINT DSMINT INTSUP $PDLOV INTNXP INTIRD INTMPV INTIWR INTILO INTMER INTASS ASSIN1 ASSRET
C01812 00527 ENBINT REAINT REAIN1 DISINT DALINT INTRPT DSMINT INTERR PARINT NXMINT ILMINT SAIMER EYEINT SAIIMS SAIDSP
C01823 00528 ENBINT REAINT REAIN2 REAIN1 DISINT DALINT APRTRP $PDLOV DSMINT UCHINT REETRP REETR1
C01831 00529 INTXIT INTXT2 INTXT9 INTLOS INTLS1 INTLS9 XUINT XUINT9
C01836 00530 MEMERR MPVERR PURERR ILOPER ILOPR1 PARERR MEMER5 MEMER7 MEMER8 UIMPAR UIMILO UIMWRO UIMMPV $XLOST $XLOSE MEMER8 UIMPAR UIMILO UIMWRO UIMMPV
C01842 00531 IOCERR IOCERA IOCER8 IOCER9
C01844 00532 CHNINT CHNI1H CHNIZ TTYI1 CHNI2
C01849 00533 CHNI4 CHNI4A CHNI5 CHNI8 CHNI4C CHNI4H
C01851 00534 JOBINT
C01853 00535 TTYICH TTYIC1
C01854 00536 CN.W CN.Z CN.Z0 ALTP CN.Z ALTP CN.Z CKI2I CTRLG CN.X CN.G CN.G1
C01857 00537 REALCLOCK RUNCLOCK RCLOK1 FNYINT FNYIN0 RCLOK2
C01859 00538 CLIINT TTRINT SYSINT MARINT
C01860 00539 YESIN1 UISTK1 UISTK2 TMDAMI TMDAM2 QMARK
C01862 00540 PURPGI PPGI3 PPGI5 PPGI6
C01864 00541 UIMPAR UIMILO UIMWRO UIMMPV UIFCLI UIFMAR UIFTTR UIFSYS NUINT1 NUINT2
C01868 00542 UINT UINTEX UINTX1 UINT2 UINT3 HHCTB UINTPU
C01871 00543 YESINT UINT0 UIXPUSH UISWS UISAVT UIFRM UISAVA
C01876 00544 UINT30 UINT31 UINT32 UINT33 UINT40 UINT0X UINT0N UINT0Z UINT88 EUINT0 UINT45 UINT46 UINT49 UINT90 UINT91
C01881 00545 CKI0 CKI2 CKI2A CKI2F CKI2F1 CKI3 CKI3B RQITR CKI4A CKI1 CKI1A
C01884 00546 UUOH0 UUOH2 UUOH2A UUOACL UUOAJC
C01886 00547 UUOH0B UUOH0A UUOH1 UUOH0C UUOH1A UUOH3B
C01888 00548 UUOTRT UUAT UUST UUFST UULT UUET UUFET UUNAF UUALT UUMCT UUALT1
C01891 00549 UUOBNC UUOBAK UUBKG1 UUOBK7 UUOBK0 UUOBK1 UUOBK8 UUOBK5 UUOBK6
C01893 00550 UUOSBR UUOSB2 UUOSB3 UUOSB5 UUOSB6 UUOSB7 UUOSB4 UUOXT0 UUOXIT UUOXT1 UUOXCT UUOACS
C01896 00551 UUOARR UUOS0 UUOS03 UUOAR2 UUONVL FIX7 UUOS1E UUOS2E UUOE3
C01899 00552 UUOS0E UUOS0F UUOE2 UUOSE1 UUOS1
C01901 00553 UUOX4B UUOLSB UUOLB3 UUOLB4 UUOFUL
C01904 00554 UUOS9 UUOS7 UUOS7A UUOS7H UUOS7K
C01906 00555 UUOS2A UUOS2 UUOS2Q CILIST UUOS1A
C01908 00556 UUOS4 UUF2N UUOS6 UUOS6Q UUOS11
C01910 00557 UUOS3 UUOS4A UUOEX2 UUOS UUOEXP UUOEX4 UUOS10 UUS10A
C01912 00558 UUL2N UUOS5 UUOS5A UUOS5B UUOS5C
C01915 00559 ARGCHK ARGLCK ARGCK1 ARGCK2 ARGCK0 ARGCK4 ARGCK3 ARGCK5 ARGPDL ARGP0 ARGP1 PDLARG PAERR PDLA2
C01917 00560 STRTOUT ERP0E ERP0F ERP0A ERBPLOC ERP1 ERP5 ERP5A ERP0D ERP0C ERP3 ERP4 ERP6 ERP6A ENDFUN
C01920 00561 LISP LISP17 LIHAC
C01927 00562 LISP43 SYMFIL TNXSET TNXST0 TNXST3 TNXST1 TNXST2 TNXUDI TNXUD0 TNXUD3 TNXUD6 TNXUD5 TNXUD2 TNXU9P TNXU9D TNXST9 TNXDIE D10SET NFLSS SUSCON LISPGO GOL1 GOL2 FLSLSP FLSPA4 FLSPA5 FLSVAL FLSVA1 FLSADJ FLSMSK FLSPA6 FLSPA1 FLSPA3 FLSST FLSDIE NOSHARE SHAREP SHARP1 PURCHK SYSFIL SYSCHN PURPGS SHRL1 SHRL2 SHRL3 SHRL4 SHRLOD PDUMPL PURCKS PUROPN PUROP1 PUROP2 PURRWO PDUMP PURCHN PURSTI PURISP PURPTR NFLSE
C01940 00563 JCLSET JCST4 JCST2 JCST5 JCST1 JCST3
C01942 00564 SFXTBL SFXTBI PROTB
C01944 00565 $IWAIT INTSFX SPWIN SPWIN1
C01947 00566 IWLOOK INTXCT
C01949 00567 INTSYP INTSYQ INTSYX INTROT INTPPC INTC2X INTC2Y INTACT INTTYX INTACX INTZAX INTBAK INTBK1 INTOK IWWIN IWSTAK
C01952 00568 PATCH EPATCH NPURPG INUM PFXEST SYMEST LSYALC GSNSYSG GSNSY2 GSNPFXSG KNOB KNOB
C01955 00569 C.. C. PNL F.
C01958 00570 PNL S. B. ZZ A C.
C01961 00571 BLSTIM DEDSAR DBM BSYSAR OBARRAY READTABLE PRDTBL TTYIFA TTYOFA INIIFA ESYSAR
C01965 00572 C. BXVCSG BXVCSG EVCSG SY2ALC SYMSYF TRUTH QUNBOUND SYALC S. ESYMGS
C01967 00573 $$$TRUTH $$$UNBOUND B. INR70 IPPN1 IPPN2 F. EPFXGS BPURFS $$UNBOUND $$NIL VNIL $$TRUTH VT VTRUTH SUNBOUND SSSBRL ASBRL SYSBRL SBRL QGRTL
C01970 00574 RDQTEB PRMCLS BSYSAP QFL.ER ER$AL QFL.HE HE$AL QFL.AL AL$AL QFL.DA DA$AL QFL.NV NV$AL ESYSAP QA%DDD IRATBL IRACOM
C01975 00575 BNM23A BNM23B BN.1A BNV2A QTLIST QLSPOUT QLSPOUT QUWL QURL LGOR
C01976 00576 QNILSETQ QTSETQ QXSETQ ARQLS $QMLST QSJCL SPCNAMES PURSPCNAMES PDLNAMES
C01978 00577 QBIGNUM PLLISP
C01983 00578
C01986 00579
C01988 00580
C01991 00581
C01992 00582
C01994 00583
C01998 00584
C02000 00585
C02003 00586 DOLLRP
C02006 00587 PFSLAST ESYSVC LISAR TYIMAN UNTYIMAN UNREADMAN READPMAN FASLP TIRPATE ARGLOC ARGNUM
C02008 00588 BFVCS INFVCS SYMSYL NXXASG NXXZSG BXXASG NXXASG BXXZSG NXXZSG NSY2SG ZZ ZZZ XHINUM XLONUM IN0
C02011 00589 BXXPSG NXXPSG NPURFS FIRSTW QXSET1 NUNMRK FEATLS
C02013 00590 BPROTECT TLF BLF QF1SB PA3 GCPSAR RDLARG SUDIR FEATURES LDFNAM LDEVPRO NILPROPS DEOFFN DENDPAGEFN LPROTECT
C02015 00591 Q. V. IGCMKL OBTFS LFSALC FSALC VBP1 VBPE1 IGCFX1 IGCFX2 LFWSALC FWSALC NIFWAL
C02017 00592 BBIGPRO BN235 BNM235 BNM236 BNV2 BN.1 LBIGPRO BBNSG NBNSG BXXBSG NXXBSG BLSTIM NBITB ZZ BTBLKS BFBTBS NBPSSG NFXPSG NFLPSG NPSG NSPSG NXFXPSG NXFLPSG NXPSG NXSPSG NNXMSG NNXMSG ZZX ZZX SPDLORG PDLORG FLPORG FXPORG ZZX ZZX SPDLORG PDLORG FLPORG FXPORG
C02022 00593 OBTL INITIALIZE
C02025 00594 INIBS INIBS1 INIBS2 INIT5
C02028 00595 BZERSG BSYSSG IN10ST IN10S5 IN10S8
C02031 00596 ININTR INIRND BINIT9 INIT1G INIT1A INIT1B INIT1D INIT1C INIT1X INIT2A INIT2B INIT7A INIT7B BINIT9 INIT99 INIT1P INIT1Q
C02039 00597 NOTINIT INIBSP INIBD INIBD1 KLINIT KLINI1 KLINI2
C02042 00598 LOPDL LOFXPDL LOSPDL LOFLPDL ALBPS
C02043 00599 XLABEL
C02044 00600 FAKJCL ALLF AINFIL ATYF LICACR ALERR ALLTYO ATYOI ALLECO SAILP4 SAIP1 SAIP2 SAIP3 ALLTYI ATI2 ATI1 ALLTYC ALOIOT
C02048 00601 ALLRUB ALLNUM ALNM2 ALNM27 ALNM3 ALNMOK ALSYER ALNMER ALLNER
C02050 00602 ALNM1 ALNM1A DECDIG DDIG1
C02052 00603 ALFDEF ALOFL2 ALOFIL ALOINI ALOJCL ALOIN1 ALOFL4 ALOFL1 ALOFL5 ALOFL6
C02055 00604 ALLFIL ALLFL1 ALLFL2 ALCLUZ ALCLZ1 ALLTTS ALHELP
C02058 00605 ALFLER ALCERR ALFL6 ALFL6A ALFL6B
C02060 00606 %ALLOC ALFDE1 ALJ1 ALJ1A ALJ1A1 ALJ1A2 ALJ1B ALJ1B1 ALJ1B2 ALJ2 ALJ2Q ALJ2A ALJ2A1 ALJ3 ALJ1 ALJ1A ALJ1A1 ALJ1A2 ALPPN1 ALJ1A3 ALJ1B ALJ1B2 ALJ2 ALJ2Q HAFPPN HAFPP1 ALJ3 ALLOCB
C02071 00607 ALLOCA ALLOC1
C02073 00608 ALCORX ALCORE ALCORX ALCORE ALLOCC
C02075 00609 ALLCZX
C02077 00610 ALLCPD
C02079 00611 ALLCPD ALCPD1 SYMMV6 ALQX1 ALSGHK ALQX2
C02084 00612 ALLDONE SYMMOV SYMMV1 LPROGS
C02085 00613 INIIF1 INIIF2 FI.EOF FI.BBC FI.BBF F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.RDEV F.DEV F.DIR F.FNM F.EXT F.VRS AT.CHS AT.LNN AT.PGN LONBFA FB.BYT FB.BFL FB.BVC FB.IBP FB.BP FB.CNT FB.HED FB.NBF FB.BWS FB.BUF LINIFA EINIFA ENDLISP ENDHI
C02090 ENDMK
C⊗;
;.MLLIT VERSION ITS TOPS10 TOPS20 SAIL TENEX CMU KA10 KI10 KL10 ML BIGNUM OBTSIZ PTCSIZ NEWRD JOBQIO HNKLOG SFA LHFLAG NIOBFS USELESS DBFLAG CXFLAG NARITH
;.MLLIT VERSION ITS TOPS10 TOPS20 SAIL TENEX CMU KA10 KI10 KL10 ML BIGNUM OBTSIZ PTCSIZ NEWRD JOBQIO HNKLOG SFA LHFLAG NIOBFS USELESS DBFLAG CXFLAG NARITH
;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
IFE .OSMIDAS-<SIXBIT \ITS\>, .SYMTAB 16001. ;ENSURE ROOM FOR MANY SYMBOLS
.ELSE .SYMTAB 11000.
TITLE ***** MACLISP ****** LISP INTERPRETER AND SYSTEM *************
.NSTGWD ;NO STORAGE WORDS PLEASE UNTIL FIRSTLOC
.XCREF A,B,C,AR1,AR2A,T,TT,D,R,F,P,FXP,%
.MLLIT==1
VERSION==.FNAM2 ;BY CONVENTION, THE SIXBIT FOR THE VERSION NUMBER
SUBTTL ASSEMBLY PARAMETERS
IF1,[ ;***** CONDITIONAL ASSEMBLY FLAGS AND PARAMETERS *****
;" FOR ASSLIS - DO NOT PUT ANY OTHER DOUBLE QUOTES ON THIS PAGE
ITS==0 ;1 FOR RUNNING UNDER THE ITS MONITOR
TOPS10==0 ;1 FOR RUNNING UNDER DEC TOPS-10 MONITOR
TOPS20==0 ;1 FOR RUNNING UNDER DEC TOPS-20 MONITOR
SAIL==0 ;1 FOR RUNNING UNDER SAIL MONITOR
TENEX==0 ;1 FOR RUNNING UNDER THE TENEX MONITOR
CMU==0 ;1 FOR RUNNING UNDER THE CMU MONITOR
;LATER WE WILL DEFINE D10==TOPS10\SAIL\CMU AND D20==TENEX\TOPS20
KA10==0 ;1 FOR KA10 PROCESSOR (WILL ALSO WORK ON KI AND KL)
KI10==0 ;1 FOR KI10 PROCESSOR (WILL ALSO WORK ON KL)
KL10==0 ;1 FOR KL10 PROCESSOR ONLY
ML==0 ;1 SAYS THIS LISP IS FOR ML (OR MC) INSTEAD OF AI (ONLY IF ITS==1)
BIGNUM==1 ;MULTIPLE PRECISION ROUTINES FLAG
OBTSIZ==777 ;LENGTH OF OBLIST
PTCSIZ==40 ;MINIMUM SIZE FOR PATCH AREA
NEWRD==0 ;NEW READER FORMAT ETC
JOBQIO==1 ;SUPPORT FOR INFERIOR PROCEDURES
HNKLOG==8 ;LOG2 OF SIZE (IN WORDS) OF LARGEST HUNK (0 => NO HUNKS)
SFA==0 ;1 FOR SFA I/O
LHFLAG==1 ;1 FOR CRETINOUS LH FEATURE FOR LONG-TERM MEMORY FOR OWL
NIOBFS==1 ;NUMBER OF I/O BUFFERS FOR D10 SYSTEMS
USELESS==1 ;NOT PARTICULARLY IMPORTANT FEATURES, LIKE:
; 1) ROMAN NUMERAL READER AND PRINTER
; 2) PRINLEVEL AND PRINLENGTH
; 3) DOUBLE-PRECISION INPUT OF SINGLE-PRECISION FLONUMS
; 4) CURSORPOS
; 5) GCD
; 6) DUMPARRAYS, LOADARRAYS [AUTOLOADED IN NEWIO]
; 7) RECLAIM, AND RETSP FEATURE WHICH RETURNS BPS CORE TO TS SYSTEM
; 8) PURIFY, AND PURE-INITIAL-READ-TABLE
; 9) CLI INTERRUPT SUPPORT
; 10) MAR-BREAK SUPPORT
; 11) AUTOLOAD PROPERTIES FOR ALLFILES ETC.
; 13) CLEVER TERPRI-BEFORE-THE-PARENS HACK
; 14) HUGE TABLE FOR RANDOM NUMBER GENERATOR
DBFLAG==0 ;1 FOR DOUBLE-PRECISION FLOATING-POINT NUMBERS
CXFLAG==0 ;1 FOR COMPLEX ARITHMETIC
NARITH==0 ;1 FOR NEW ARITHMETIC PACKAGE
;" FOR ASSLIS - DOUBLE QUOTES ARE OKAY NOW
;
;
;;; IF1
SUBTTL STORAGE LAYOUTS
;;; STORAGE LAYOUT FOR ITS
;;;
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSYSSG FIRSTL: INITIAL SYSTEM CODE (PURE)
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; C(BPSL) (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS
;;; ... BINARY PROGRAM SPACE GROWS UPWARD ...
;;; C(HINXM) LAST WORD OF GROSS HOLE IN MEMORY
;;; ... LIST STRUCTURE GROWS DOWNWARD ...
;;; PUSHDOWN LISTS WITH HOLES BETWEEN:
;;; FXP, FLP, P, SP
;;;
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;;
;;; STORAGE LAYOUT FOR DEC10
;;;
;;; ***** LOW SEGMENT *****
;;; BZERSG 0 - - LOW PAGES
;;; ACCUMULATORS, TEMPORARY VARIABLES,
;;; INITIAL READTABLE AND OBARRAY
;;; BSTSG ST: - - SEGMENT TABLES
;;; BSARSG INITIAL SAR SPACE
;;; BVCSG INITIAL VALUE CELL SPACE
;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE]
;;; BIS2SG SYMBOL-BLOCKS
;;; BSYMSG SYMBOL-HEADERS
;;; BIFSSG LIST-STRUCTURE
;;; BIFXSG FIXNUMS
;;; BIFLSG FLONUMS
;;; BBNSG BIGNUMS
;;; BBITSG BIT BLOCKS FOR GC
;;; PUSHDOWN LISTS:
;;; FXP, FLP, P, SP
;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP)
;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP)
;;; BBPSSG START OF BINARY PROGRAM SPACE
;;; (ALLOC IS IN THIS AREA)
;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS
;;; V(BPEND) ARRAYS START NO LOWER THAN THIS
;;; C(BPSH) LAST WORD OF BPS (FIXED, SET BY ALLOC)
;;; C(HIXM) HIGH WORD OF EXISTING MEMORY
;;; C(MAXNXM) HIGHEST WORD OF NXM THAT MAY BE USED
;;;
;;; ***** HIGH SEGMENT *****
;;; BSYSSG INITIAL SYSTEM CODE (PURE)
;;; BSY2SG **SYMBOL-BLOCKS
;;; BPFXSG **FIXNUMS
;;; BPFSSG **LIST-STRUCTURE
;;; BPFLSG [**FLONUMS - - POSSIBLY NONE]
;;; BPFSSG INITIAL PURE LIST STRUCTURE
;LVRNO LVRNO ZZZ ZZZ DEFAULT
;LVRNO LVRNO ZZZ ZZZ DEFAULT
;;; IF1
SUBTTL VARIOUS PARAMETER CALCULATIONS
LVRNO==.FNAM2
IFGE LVRNO,[
LVRNO==<LVRNO←-6>+<SIXBIT \1\> ;HACK FOR CROSSING 1000'S
;IFN <<LVRNO←-30>&77>-'9, LVRNO==LVRNO+<1←36> ;INSTALL THIS LINE WHEN 1900 REACHED
] ;END OF IFGE LVRNO
PRINTX \MACLISP VERSION \ ;PRINT OUT VERSION OF THIS LISP
.TYO6 .OFNM2
PRINTX \ [\ ;WATCH OUT FOR THE BRACKETS!
.TYO6 LVRNO
PRINTX \] ASSEMBLED ON \
.TYO6 .OSMIDAS
PRINTX \ AT \
IFE <.SITE 0>, PRINTX \UNKNOWN SITE\
.ELSE REPEAT 20, IFE <.SITE .RPCNT>,[.ISTOP] .TYO6 <.SITE .RPCNT>
PRINTX \
\ ;TERPRI TO FINISH VERSION MESSAGE
;;; HACK FLAGS AND PARAMETERS
DEFINE ZZZZZZ X,SYM,VAL
IFSE [X]-, PRINTX \* \
.ELSE PRINTX \ \
PRINTX \SYM=VAL
\
TERMIN
PRINTX \INITIAL SWITCH VALUES (*=EXPERIMENTAL):
\
;X=- => EXPERIMENTAL SWITCH
IRPS S,X,[ITS,TOPS10,TOPS20,SAIL,TENEX-CMU-KA10,KI10-KL10-
ML,BIGNUM,OBTSIZ,JOBQIO,HNKLOG,USELESS,
DBFLAG-CXFLAG-NARITH-SFA-]
ZZZZZZ [X]S,\S
TERMIN
EXPUNGE ZZZZZZ
PRINTC \REDEFINITIONS:
\
.INSRT TTY:
PRINTC \
\
;;; ALL FLAGS WHICH ARE NON-ZERO MUST BE ONES: MUCH CONDITIONAL
;;; ASSEMBLY DOES ARITHMETIC WITH THEM.
IRP FOO,,[ITS,TOPS10,TOPS20,SAIL,TENEX,CMU,KA10,KI10,KL10
ML,BIGNUM,NEWRD,JOBQIO,USELESS
LHFLAG,DBFLAG,CXFLAG,NARITH,SFA]
IFN FOO, FOO==:1
.ELSE FOO==:0
TERMIN ;USE OF ==: PREVENTS CHANGING THEM RANDOMLY
;;; CHECK MUTUALLY EXCLUSIVE FLAGS OF WHICH ONE MUST BE SET
DEFINE MUTXOR FLAGS,DEFAULT
ZZZ==0
IRP X,Y,[FLAGS]
ZZZ==ZZZ+X
IRP Z,,[Y]
IFN X*Z, .FATAL BOTH X AND Z SPECIFIED AMONG {FLAGS}
TERMIN
TERMIN
IFE ZZZ,[
PRINTX \NONE OF {FLAGS} SPECIFIED - ASSUMING DEFAULT==:1
\
EXPUNGE DEFAULT
DEFAULT==:1
] ;END OF IFE ZZZ
EXPUNGE ZZZ
TERMIN
IRP OS,,[ITS,DEC,SAIL,TENEX,CMU]FLAG,,[ITS,TOPS10,SAIL,TENEX,CMU]
IFE .OSMIDAS-<SIXBIT \OS\>, MUTXOR [ITS,TOPS10,TOPS20,SAIL,TENEX,CMU]OS
TERMIN
MUTXOR [KA10,KI10,KL10]KA10
;D10 D20 ZZZ SEGLOG OBTSIZ DXFLAG
;;; IF1
D10==:TOPS10\SAIL\CMU ;SWITCH FOR DEC-10-LIKE SYSTEMS
D20==:TOPS20\TENEX ;SWITCH FOR DEC-20-LIKE SYSTEMS
IFNDEF PAGING, PAGING==:D20\ITS ;SWITCH FOR PAGING SYSTEMS
IFNDEF HISEGMENT, HISEGMENT==:D10*<1-PAGING> ;ASSUME HISEGMENT FOR DEC-10
;;; INSIST FORCIBLY ALTERS A PARAMETER IF NECESSARY.
DEFINE INSIST COND,SET
COND,[
IRPS X,,[SET]
ZZZ==X
EXPUNGE X
SET
IFN X-ZZZ,[
PRINTX \ COND =>SET
\
]
EXPUNGE ZZZ
.ISTOP
TERMIN
] ;END OF COND
TERMIN
;;; CANONICALIZE BITS
INSIST IFE ITS, JOBQIO==:0
INSIST IFE ITS, LHFLAG==:0
INSIST IFG SAIL*<6-NIOBFS>, NIOBFS==:6
;INSIST IFN TOPS20, KA10==:0
;INSIST IFN TOPS20, KI10==:0
;INSIST IFN TOPS20, KL10==:1
SEGLOG==:11 ;LOG2 OF # OF WORDS PER SEGMENT (WARNING! BUILT INTO NCOMPLR!)
INSIST IFGE HNKLOG-SEGLOG, HNKLOG==:SEGLOG/2
OBTSIZ==:OBTSIZ\1 ;MUST BE ODD
DXFLAG==:DBFLAG*CXFLAG
;$GET
;;; IF1
IFE .OSMIDAS-<SIXBIT \ITS\>,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
.TYO6 .IFNM1
PRINTX \ \
.TYO6 .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
.ELSE,[
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
.TYO6 .IFNM1
PRINTX \.\
.TYO6 .IFNM2
PRINTX \
\
TERMIN
] ;END OF .ELSE
;;; MAKE SURE THE SYMBOLS WE WILL NEED ARE DEFINED.
;;; THEY MAY NOT BE IF ASSEMBLING FOR A DIFFERENT OPERATING SYSTEM
DEFINE FLUSHER DEF/
IRPS SYM,,[DEF]
EXPUNGE SYM
.ISTOP
TERMIN
TERMIN
DEFINE SYMFLS TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFE <.OSMIDAS-SIXBIT\OS\>,[
IFE TARGETSYS,[
PRINTX \FLUSHING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER FLUSHER
IFSN .BITS.,,[
PRINTX \FLUSHING OS BIT DEFINITIONS
\
EQUALS DEFSYM,FLUSHER
$INSRT .BITS.
EXPUNGE DEFSYM
] ;END OF IFSN .BITS.
] ;END OF IFE TARGETSYS
] ;END OF IFE <.OSMIDAS-SIXBIT\OS\>
TERMIN
DEFINE SYMDEF TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFN TARGETSYS,[
IFN <.OSMIDAS-SIXBIT\OS\>,[
PRINTX \MAKING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER
IFSN .BITS.,,[
PRINTX \MAKING OS BIT DEFINITIONS
\
$INSRT .BITS.
] ;END OF IFSN .BITS.,,
] ;END OF IFN <.OSMIDAS-SIXBIT\OS\>
.ELSE,[
IFNDEF CHKSYM,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKSYM UNDEFINED; MAKING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER
] ;END OF IFNDEF CHKSYM
IFSN .BITS.,,[
IFNDEF CHKBIT,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKBIT UNDEFINED; MAKING OS BIT DEFINITIONS
\
$INSRT .BITS.
] ;END OF IFNDEF CHKBIT
] ;END OF IFSN .BITS.,,
] ;END OF .ELSE
] ;END OF IFN TARGETSYS
TERMIN
IFN D20, EXPUNGE RESET
IRP HACK,,[SYMFLS,SYMDEF]
HACK ITS,ITS,ITSDFS,.ITSDF,.IOT,ITSBTS,%PIC.Z
HACK TOPS10,DEC,DECDFS,.DECDF,LOOKUP,DECBTS,.GTSTS
HACK TOPS20,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
HACK SAIL,SAIL,SAIDFS,.DECDF,SPCWAR,DECBTS,.GTSTS
HACK TENEX,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
HACK CMU,CMU,CMUDFS,.DECDF,CMUDEC,DECBTS,.GTSTS
TERMIN
;;; CONFLICTS WITH UNLOCKI MACRO AND SEGSIZ VARIABLE
IFN D10, EXPUNGE UNLOCK
IFN SAIL, EXPUNGE SEGSIZ
;;; CONFLICTS WITH VARIOUS LABEL DEFINITIONS UNDER TENEX/TWENEX
IFN D20,[
$GET==:GET
EXPUNGE GET
] ;END IFN TENEX\TOPS20
COMMENT | MAKE @ PROGRAM UNDERSTAND POTENTIAL FILE INSERTIONS
;TABS IN FRONT OF $INSRT'S ARE NECESSARY TO FAKE OUT UNIFY PROGRAM
$INSRT ITSDFS
$INSRT DECDFS
$INSRT TNXDFS
$INSRT SAIDFS
$INSRT CMUDFS
$INSRT ITSBTS
$INSRT DECBTS
$INSRT TWXBTS
| ;END OF COMMENT
IFN D10,[
DEFINE HALT
JRST 4,.!TERMIN
EXPUNGE .VALUE
EQUALS .VALUE HALT
DEFINE .LOSE <A>
JRST 4,.-1!TERMIN
] ;END OF IFN D10
IFN D20,[
IFN TOPS20, GETTAB==:47←33 41
DEFINE HALT
HALTF!TERMIN
EXPUNGE .VALUE
EQUALS .VALUE HALTF
DEFINE .LOSE <A>
HALTF!TERMIN
] ;END OF IFN D20
;NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP
;;; IF1
;;; LOSING KL10 HAS A FIX INSTRUCTION
EXPUNGE FIX
;;; CALL IS A DEC UUO, BUT WE USE THAT NAME FOR A LISP UUO
EXPUNGE CALL
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
;;@ DEFNS 173 STANDARD AC, UUO, AND MACRO DEFINITIONS
;;; ***** MACLISP ****** STANDARD AC, UUO, AND MACRO DEFINITIONS *
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; THIS FILE CONTAINS:
;;; STANDARD SYMBOLIC ACCUMULATOR DEFINITIONS.
;;; UUO DEFINITIONS:
;;; ERROR CALLS AND STRING TYPEOUT.
;;; COMPILED CODE TO INTERPRETER INTERFACES.
;;; VARIOUS UUOS USEFUL FROM DDT.
;;; .GLOBAL DECLARATIONS.
;;; .FORMAT DECLARATIONS.
;;; TYPE BIT DEFINITIONS FOR USE WITH SEGMENT TABLE
;;; MACROS FOR CONDITIONALIZING SINGLE LINES OF CODE.
;;; GENERAL MACRO DEFINITIONS [THAT ANY LOSER MIGHT WANT].
;;; SYMBOL BLOCK-STRUCTURE DEFINITIONS
;;; SYMBOLIC NAMES RELATED TO ARRAYS.
;;; SYMBOLIC NAMES RELATED TO FILES.
;;; THE DEFINITIONS FOR MACLISP CONTAINED HEREIN
;;; ARE RELATIVELY STABLE. THIS FILE MAY BE .INSRT'D BY MIDAS
;;; FILES ASSEMBLED IN .FASL MODE TO DEFINE THESE THINGS.
;;; THE .GLOBAL DECLARATIONS IN PARTICULAR ARE FOR THE
;;; BENEFIT OF THESE .FASL FILES.
;;; IT IS A GOOD IDEA FOR .FASL FILES TO USE THE FASEND MACRO
;;; IN PLACE OF THE USUAL END STATEMENT.
SUBTTL ACCUMULATOR USAGE
NIL=:0 ;ATOM HEADER FOR NIL
A=:1 ;ARG 1; VALUE; MARKED FROM BY GC
B=:2 ;ARG 2; MARKED FROM BY GC
C=:3 ;ARG 3; MARKED FROM BY GC
AR1=:4 ;ARG 4; MARKED FROM BY GC
AR2A=:5 ;ARG 5; MARKED FROM BY GC
NACS==:5 ;NUMBER OF ACS MARKED FROM BY GC - NO OTHER ACS MARKED
T=:6 ;-<NO. OF ARGS> FOR LSUBR CALL; ALSO USED FOR JSP T,
TT=:7 ;TEMP; OFTEN USED FOR ARGS TO INTERNAL ROUTINES
D=:10 ;SOMEWHAT LESS TEMPORARY THAN TT
R=:11 ;DITTO; SOMETIMES USED FOR JSP R,
F=:12 ;SOMEWHAT LESS TEMPORARY THAN D AND R
FREEAC=:13 ;UNUSED BY LISP, EXCEPT SAVED-USED-RESTORED BY GC
P=:14 ;SUBROUTINE AND SYSTEM PDL POINTER ("REGULAR PDL")
FLP=:15 ;FLONUM PDL POINTER ("FLOPDL")
FXP=:16 ;FIXNUM PDL POINTER ("FIXPDL")
SP=:17 ;LAMBDA-BINDINGS PDL POINTER ("SPECIAL PDL")
;;; PDL POINTERS ARE ALWAYS KEPT IN ACS. PDL POINTERS ARE NOT
;;; MARKED FROM, BUT PDL DATA ON REGULAR AND SPECIAL PDLS ARE
;;; PROTECTED FROM GARBAGE COLLECTION.
;;; FLP IS NOT USED BY LISP, EXCEPT AT LDATFL AND ERRIOJ,
;;; BUT PRIMARILY BY COMPILED NUMERICAL CODE.
;;; DO NOT DO RANDOM PUSH/POPS ON SP - USE BIND AND UNBIND ROUTINES.
;LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS NERINT NERINT
SUBTTL DEFINITIONS OF UUO'S
;;; NOTE: LERR < LER3 < ERINT < SERINT -- SEE ERRFRAME.
LERR=:1←33 ;LISP ERROR; AC FIELD=0 => MSG IS SIXBIT, ELSE S-EXP
ACALL=:2←33 ;KLUDGY FAST UUO FOR NCALLS TO ARRAYS
AJCALL=:3←33 ;AJCALL:ACALL :: JCALL:CALL
LER3=:4←33 ;EPRINT, THEN LERR
ERINT=:5←33 ;A CORRECTABLE ERROR
PP=:6←33 ;SEXP TYPE OUT FROM DDT
STRT=:7←33 ;STRING TYPEOUT
SERINT=:10←33 ;LIKE ERINT, BUT S-EXPRESSION MESSAGE.
TP=:11←33 ;PRINTS ST ENTRY FOR A GIVEN LOCATION
IOJRST=:12←33 ;JRST TO ADR AFTER PUTTING I/O ERROR MSG IN C
UUOMAX==:12 ;NO OF ERROR-TYPE UUO'S
CALL=:14←33 ;BASIC CALL FROM COMPILED CODE TO INTERFACE TO INTERPRETER
JCALL=:CALL+1←33 ;4.1 BIT ON MEANS JRST TO FUNCTION RATHER THAN PUSHJ
CALLF=:CALL+2←33 ;4.2 BIT ON MEANS NEVER CONVERT UUO INTO PUSHJ [OR JRST]
JCALLF=:CALL+3←33
NCALL=:20←33 ;4.5 BIT MEANS NUMBER FUNCTION CALL
NJCALL=:NCALL+1←33
NCALLF=:NCALL+2←33
NJCALF=:NCALL+3←33
NUUOCLS==:NJCALF←-33-CALL←-33
;;; SPECIAL INTERPRETATION OF STRT AC FIELD:
;;; AC FIELD OUTPUT TO
;;; 0 OUTFILES IF ↑R SET; TTY IF ↑W SET
;;; 17 MSGFILES
;;; X FILE(S) IN ACCUMULATOR X
;;; ERINT AND SERINT ARE DECODED BY THEIR ACCUMULATOR FIELDS.
;;; HERE ARE SOME SYMBOLS FOR REFERENCING THEM.
NERINT==0
IRPS X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC,IOL]
%!X=:ERINT .IRPCNT,
%%!X=:SERINT .IRPCNT,
DEFINE X CRUFT
%!X [SIXBIT ≤CRUFT≤]
TERMIN
NERINT==NERINT+1
TERMIN
;;; SHORT FORM ATOM WHAT IS IT?
;;;
;;; 0) UDF UNDEF-FNCTN UNDEFINED FUNCTION (FUNCTION IN A)
;;; 1) UBV UNBND-VRBL UNBOUND VARIABLE BEING EVAL'ED (ATOM IN A)
;;; 2) WTA WRNG-TYPE-ARGS WRONG TYPE OF ARGUMENTS FOR A FUNCTION (ARG IN A)
;;; 3) UGT UNSEEN-GO-TAG GO TO A TAG THAT'S NOT THERE (TAG IN A)
;;; 4) WNA WRNG-NO-ARGS WRONG NUMBER OF ARGS TO A FUNCTION (FORM IN A)
;;; 5) GCL GC-LOSSAGE GC LOST (A = NAME OF SPACE: LIST...)
;;; 6) FAC FAIL-ACT RANDOM LOSSAGE (ARG IS UP TO CALLER)
;;; 7) IOL IO-LOSSAGE ;I/O LOSSAGE
;
SUBTTL TABLE OF GLOBAL SYMBOLS USED BY COMPILED FUNCTIONS
;;; THE RELATIVE POSITIONS OF THESE SYMBOLS GET BUILT INTO FASL FILES,
;;; SO BE VERY CAREFUL ABOUT DISTURBING THE ORDER OF EXISTING SYMBOLS!
;;; GLBSYM AND SIXSYM MUST ALWAYS HAVE CORRESPONDING ENTRIES.
DEFINE GLBSYM B
IRP A,,[.SET,.MAP,PRINTA,SPECBIND,UNBIND,IOGBND,.LCALL
.UDT,ARGLOC,INUM,ST,FXNV1,PDLNMK,PDLNKJ,FIX1A
FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO
GOBRK,CARCDR,.STORE,NPUSH,PA3,QUNBOUND,FLTSKP,FXNV2
FXNV3,FXNV4,FIX2,FLOAT2,AREGET]
B
TERMIN
IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0.0PUSH,NILPROPS,VBIND
%CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC
PTNTRY,PTEXIT,SFCALI,UNWPUS]
B
TERMIN
TERMIN
DEFINE SIXSYM B ;SIXBIT NAMES -- MUST MATCH GLBSYM
IRP A,,[*SET,*MAP,PRINTA,SPECBIND,UNBIND,IOGBND,*LCALL
*UDT,ARGLOC,INUM,NUMVAL,FXNV1,PDLNMK,PDLNKJ,FIX1A
FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO
GOBRK,CARCDR,*STORE,NPUSH,PA3,MAKUNBOUND,FLTSKP,FXNV2
FXNV3,FXNV4,FIX2,FLOAT2,AREGET]
B
TERMIN
IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0*0PUSH,NILPROPS,VBIND
%CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC
PTNTRY,PTEXIT,SFCALI,UNWPUS]
B
TERMIN
TERMIN
;;; ADDITIONAL SYMBOLS FOR LAP AND .FASL HACKERS.
;;; THE ORDER OF THESE IS NOT CRITICAL.
DEFINE XTRSYM B
IFN ITS,[
IRP A,,[GETCOR,BRGEN,RINTERN,LPNF,PNBUF,IOCINS]
B
TERMIN
] ;END OF IFN ITS
IFN D10,[
IRP A,,[PPNATM]
B
TERMIN
] ;END OF IFN D10
IFN BIGNUM,[
IRP A,,[BNCONS,NVSKIP]
B
TERMIN
] ;END OF IFN BIGNUM
IRP A,,[CPOPJ,CCPOPJ,POPAJ,POP1J,CINTREL,LWNACK,SIXMAK,SQUEEZE,MKFXAR,FWCONS
SACONS,CFIX1,1DIMF,2DIMF,SEGLOG,R70,ARGLOC,ARGNUM,TTSAR,Q..MIS,MAKVC,SUNBOUND
IN0,TYIMAN,READ6C,READ0A,GCMKL,DEDSAR]
B
TERMIN
IRP A,,[ALFILE,ALCHAN,XFILEP,FIL6BT,6BTNML,SIXATM,CHNTB]
B
TERMIN
IFN JOBQIO,[
IRP A,,[JOBTB,LOJOBA]
B
TERMIN
] ;END OF IFN JOBQIO
IFN SFA,[
IRP A,,[AFOSP]
B
TERMIN
] ;END IFN SFA
TERMIN
;;; SYMBOLS FOR COMPILED CODE
IFNDEF ITS, ITS==:1
IFNDEF TOPS10, TOPS10==:0
IFNDEF TOPS20, TOPS20==:0
IFNDEF SAIL, SAIL==:0
IFNDEF TENEX, TENEX==:0
IFNDEF CMU, CMU==:0
IFNDEF D10, D10==:TOPS10\SAIL\CMU
IFNDEF D20, D20==:TOPS20\TENEX
IFNDEF BIGNUM, BIGNUM==:1
IFNDEF JOBQIO, JOBQIO==:1
IFNDEF SFA, SFA==:1
GLBSYM [.GLOBAL A]
XTRSYM [.GLOBAL A]
;%SY %SYHKL %SYKIL %SYLCL %SYGBL BYTSWD
SUBTTL SYMBOLS FOR NUMBER-OF-ARGS CHECKING, AND .FORMAT
;;; SYMBOLS TO BE USED WITH FWNACK AND LWNACK.
;;; ORDINARILY ONE WRITES
;;; JSP TT,FWNACK
;;; FAXXX,,QZZZZZ
;;; IN EACH SYMBOL, THE 3.1 BIT (THESE ARE LEFT-HALF SYMBOLS)
;;; MEANS FSUBR. THE 3.2 BIT MEANS 0 ARGS IS OKAY; 3.3, 1 ARG;
;;; 3.4, 2 ARGS; ... ; 4.8, 15. ARGS; 4.9, > 15. ARGS.
;;; ITEMS IN THIS IRP MUST HAVE FIRST FOUR CHARS UNIQUE!!!
;;; IF YOU ADD STUFF HERE, ALSO FIX UP FASEND.
.SEE FASEND
IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567
13456,234,345,234567,76543]
LA!X==0
IRPC Q,,[X]
IFSN Q,N, LA!X==LA!X+2←Q
.ALSO ZZ==Q
.ELSE LA!X==LA!X+<<777774←ZZ>&7777777>
TERMIN
FA!X==LA!X+1
TERMIN
;;; THE FOLLOWING FORMATS ARE HEREBY DECLARED ILLEGAL AS
;;; BEING REDUNDANT AND/OR GROSSLY CONFUSING.
;;; SEE THE MIDAS MANUAL FOR DETAILS.
;;; ,A
;;; ,A C
;;; ,A,
;;; ,A,C
;;; A B C
;;; A,
;;; A,B
;;; A,B C
;;; A,B,
;;; A,B,C
IRP X,,[14,15,16,17,25,30,34,35,36,37]
.FORMAT X,0
TERMIN
;;; FLAG BITS FOR SQUOZE SYMBOLS IN DDT
%SY==1,,537777
%SYHKL==:400000 ;HALF KILLED
%SYKIL==:200000 ;FULLY KILLED
%SYLCL==:100000 ;LOCAL
%SYGBL==:40000 ;GLOBAL
;;; A FEW RANDOMLY USEFUL DEFINITIONS TO KEEP THINGS SYMBOLIC
;;; BUT WATCH OUT! DONT JUST RANDOMLY THINK YOU CAN CHANGE NASCII
;;; AND HAVE THINGS WIN, ESPECIALLY THE PACKING OF CHARS FOR
;;; PNAMES, AND THE SPECIAL OBARRAY ENTRIES FOR SCOS.
IFN SAIL, NASCII==:1000 ;NUMBER OF ASCII CHARS
.ELSE NASCII==:200 ;NUMBER OF ASCII CHARS
BYTSWD==:5 ;NUMBER OF ASCII BYTES PER WORD
;LS ST.LS $FS ST.$FS FX ST.FX FL ST.FL BN ST.BGN SY ST.SY SA ST.SA VC ST.VAC $PDLNM ST.$PDLNM $XM ST.$XM $NXM ST.$NXM PUR ST.PUR HNK ST.HNK DB ST.DB CX ST.CX DX ST.DX RN NUM ST.
SUBTTL DEFINITIONS OF BIBOP TYPE BITS FOR USE IN THE SEGMENT TABLE
.SEE ST
LS==:400000 ;4.9 1=LIST STRUCTURE, 0=ATOMIC
ST.LS==:400000
$FS==:200000 ;4.8 FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO)
ST.$FS==:200000
FX==:100000 ;4.7 FIXNUM STORAGE
ST.FX==:100000
FL==:40000 ;4.6 FLONUM STORAGE
ST.FL==:40000
BN==:20000 ;4.5 BIGNUM HEADER STORAGE
ST.BGN==:20000
SY==:10000 ;4.4 SYMBOL HEADER STORAGE
ST.SY==:10000
SA==:4000 ;4.3 SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO)
ST.SA==:4000
VC==:2000 ;4.2 VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO)
ST.VAC==:2000
$PDLNM==:1000 ;4.1 NUMBER PDL AREA
; (ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO)
ST.$PDLNM==:1000
;3.9 400 RESERVED - AVOID USING (FORMERLY $FLP)
$XM==:200 ;3.8 EXISTENT (RANDOM) AREA
ST.$XM==:200
$NXM==:100 ;3.7 NONEXISTENT (RANDOM) AREA
ST.$NXM==:100
PUR==:40 ;3.6 PURE SPACE
; (ONE OF BITS 4.8-4.5, 3.8, OR 3.4-3.2 ALSO ON)
ST.PUR==:40
HNK==:20 ;3.5 HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO)
ST.HNK==:20
DB==:10 ;3.4 DOUBLE-PRECISION FLONUMS
ST.DB==:10
CX==:4 ;3.3 COMPLEX NUMBERS
ST.CX==:10
DX==:2 ;3.2 DOUBLE-PRECISION COMPLEX NUMBERS
ST.DX==:2
;3.1 1 UNUSED (USE THIS BEFORE BIT 3.9)
RN==:$XM+$NXM ;RANDOMNESS!
NUM==:FX+FL+BN+DB+CX+DX ;NUMBERNESS!
ST.==:1,,<ST.LS+ST.FX+ST.BGN+ST.SA+ST.$PDLNM+ST.$NXM+ST.HNK+ST.CX+1>
;
SUBTTL ONE-LINE CONDITIONAL MACROS
;;; THESE HELP MAKE SOME CODE LESS MESSY TO READ.
;;; PREFACING A LINE OF CODE WITH ONE OF THESE SYMBOLS TELLS MIDAS
;;; TO ASSEMBLE THAT LINE ONLY UNDER THE SPECIFIED CONDITION.
;;; EXAMPLE:
;;;
;;; FOO: MOVE A,(P)
;;; 10$ PUSHJ P,10HACK ;THIS LINE IS FOR DEC-10 ONLY
;;; MOVE A,-1(P)
;;; Q% PUSHJ P,OLDHAK ;THIS LINE IS FOR OLD I/O ONLY
;;; POPJ P,
DEFINE 10$
IFN D10,TERMIN
DEFINE 10%
IFE D10,TERMIN
DEFINE IT$
IFN ITS,TERMIN
DEFINE IT%
IFE ITS,TERMIN
DEFINE 20$
IFN D20,TERMIN
DEFINE 20%
IFE D20,TERMIN
DEFINE 10X
IFN TENEX,TERMIN
DEFINE SA$
IFN SAIL, TERMIN
DEFINE SA%
IFE SAIL,TERMIN
DEFINE CMU$
IFN CMU,TERMIN
DEFINE CMU%
IFE CMU,TERMIN
DEFINE T10$
IFN TOPS10,TERMIN
DEFINE T10%
IFE TOPS10,TERMIN
DEFINE 20X
IFN TOPS20,TERMIN
;;; NEWRD IS FOOLISH NEW READER FLAG (HISTORICAL ARTIFACT -- FLUSH EVENTUALLY)
DEFINE NW$
IFN NEWRD,TERMIN
DEFINE NW%
IFE NEWRD,TERMIN
DEFINE BG$
IFN BIGNUM,TERMIN
DEFINE BG%
IFE BIGNUM,TERMIN
DEFINE DB$
IFN DBFLAG,TERMIN
DEFINE DB%
IFE DBFLAG,TERMIN
DEFINE CX$
IFN CXFLAG,TERMIN
DEFINE CX%
IFE CXFLAG,TERMIN
DEFINE DX$
IFN DXFLAG,TERMIN
DEFINE DX%
IFE DXFLAG,TERMIN
DEFINE HN$
IFN HNKLOG,TERMIN
DEFINE HN%
IFE HNKLOG,TERMIN
DEFINE KA
IFN KA10,TERMIN
DEFINE KAKI
IFN KA10+KI10,TERMIN
DEFINE KI
IFN KI10,TERMIN
DEFINE KIKL
IFN KI10+KL10,TERMIN
DEFINE KL
IFN KL10,TERMIN
DEFINE PG$
IFN PAGING,TERMIN
DEFINE PG%
IFE PAGING,TERMIN
DEFINE SFA$
IFN SFA,TERMIN
DEFINE SFA%
IFE SFA,TERMIN
DEFINE HS$
IFN HISEGMENT,TERMIN
DEFINE HS%
IFE HISEGMENT,TERMIN
DEFINE REL$
IFE D20\<D10*PAGING>,TERMIN
DEFINE REL%
IFN D20\<D10*PAGING>,TERMIN
;
SUBTTL GENERAL MACROS
DEFINE CONC A,B ;HAIRY CONCATENATOR MACRO
A!B!TERMIN
DEFINE LOCKI ;LOCK OUT USER INTERRUPTS UNTIL UNLOCKI'D
PUSH FXP,INHIBIT
SETOM INHIBIT
TERMIN
DEFINE UNLOCKI ;RELEASE THE USER-INTERRUPT LOCK, AND CHECK TO SEE
PUSHJ P,INTREL ;IF ANY INTERRUPTS WERE STACKED UP WHILE IN LOCKED STATE
TERMIN
DEFINE LOCKTOPOPJ ;LOCK ALL THE ENSUING CODE UNTIL THE
PUSH P,CINTREL ;EXITING POPJ P,
LOCKI
TERMIN
DEFINE UNLKPOPJ ;UNLOCK, THEN POPJ P,
JRST INTREL
TERMIN
.SEE CHNINT
DEFINE .5LOCKI ;HALF-LOCK INHIBIT
PUSH FXP,INHIBIT
HRROS INHIBIT
TERMIN
DEFINE .5LKTOPOPJ
PUSH P,CINTREL
.5LOCKI
TERMIN
IRP PL,,[,FX]
DEFINE SAVE!PL AL/ ;CALLED LIKE SAVE A B C
IRPS AC,,AL
PUSH PL!P,AC
TERMIN
TERMIN
DEFINE RSTR!PL AL/ ;CALLED LIKE RSTR C B A
IRPS AC,,AL
POP PL!P,AC
TERMIN
TERMIN
TERMIN
DEFINE MACROLOOP COUNT,NAME,C ;FOR EXPANDING MANY MACROS
IFSN C,, .CRFOFF
REPEAT COUNT,[ CONC NAME,\.RPCNT
]
IFSN C,, .CRFON
TERMIN
;SKIP IF TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS
DEFINE SKOTT /Z
SKOTT% N,L,Z
TERMIN
;SKIP IF NOT TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS
DEFINE SKOTTN /Z
SKOTT% E,GE,Z
TERMIN
DEFINE SKOTT% N,L,X,TYP
IFN TT-<X>, HRRZ TT,X
LSH TT,-SEGLOG
IFN <TYP>-LS,[
MOVE TT,ST(TT)
TLN!N TT,<TYP>
]
.ELSE SKIP!L TT,ST(TT)
TERMIN
;LABEL
DEFINE % ;THIS IS GOOD FOR LIST STRUCTURE
,,.+1!TERMIN
DEFINE INFORM R,S,T,U,V,W,X,Y,Z,$,%
PRINTX ≤ R!S!T!U!V!W!X!Y!Z!$!%
≤
TERMIN
DEFINE WARN R,S,T,U,V,W,X,Y,Z,$,%
WARN1 [R!S!T!U!V!W!X!Y!Z!$!%]
TERMIN
DEFINE WARN1 CRUFT
IFL 40-.LENGTH ≤CRUFT≤,[ .ERR ######
PRINTX ≤ ###### CRUFT
≤
]
.ELSE .ERR ###### CRUFT
TERMIN
;;; USEFUL MACRO FOR .FASL FILES. CAUSES LOADING TO PRINT MESSAGE.
DEFINE VERPRT NAME
.SXEVAL (COND ((STATUS NOFEATURE NOLDMSG)
(TERPRI MSGFILES)
(TYO #73 MSGFILES)
(PRINC (QUOTE L/o/a/d/i/n/g/ NAME/ ) MSGFILES)
(DO ((N #<.FNAM2> (LSH N #6 )))
((ZEROP N))
(TYO (PLUS #40 (LSH N #-30. ))
MSGFILES))))
TERMIN
;MACRO TO HANDLE UNWIND-PROTECT
; UNWINDPROTECT CODE,CONTINUATION-CODE
;CAUSES CONTINUATION TO BE INVOKED AFTER CODE IS EXECUTED
;THE STATE OF THE PDLS MUST BE THE SAME BEFORE AND AFTER CODE EXECUTES.
; CODE SHOULD BE THOUGHT OF AS A FUNCTION CALL.
; CODE IS THE CODE TO BE INVOKED AND PROTECTED.
; CONT IS THE "CONTINUATION" TO BE RUN WHEN UNWINDING THE STACK, OR AFTER
; CODE IS RUN
DEFINE UNWINDPROTECT CODE,CONT,\LABEL
JSP TT,PTNTRY ;SETUP AN UNWIND PROTECT
JRST LABEL
CONT
POPJ P,
LABEL:
CODE
;ASSUMPTION IS THAT FOLLOWING JSP CLOBBERS THE WORLD
JSP TT,PTEXIT ;RUN CONTINUATION, PRESERVES A
TERMIN
;NBITMACS NBITMACS XX YY
IF1,[
;;; FEATURE SO THAT HAIRY SUMS OF BITS MAY BE WRITTEN NICELY.
;;; BITMAC FOO,FOO.
;;; CAUSES THE FORM
;;; FOO<A+B+C>
;;; TO EXPAND INTO THE FORM
;;; FOO.A+FOO.B+FOO.C
NBITMACS==0
DEFINE BITMAC XX,YY,ZZ=[1,,525252]
DEFINE XX<BITS>
IRPS J,K,[BITS]
YY!!J!K!TERMIN TERMIN
BITMA1 XX,YY,[ZZ]\NBITMACS
NBITMACS==NBITMACS+1
TERMIN
DEFINE BITMA1 XX,YY,ZZ,NN
DEFINE BTMC!NN
EXPUNGE XX,YY
XX==ZZ
YY==ZZ
IFSN [ZZ], IFGE <.TYPE ZZ>, EXPUNGE ZZ
TERMIN
TERMIN
IRP FOO,,[%TB,%TI,%TJ,%TX,%TO,%TS,%TC,%TG,%TT,%PI,%PJ]
IFDEF FOO, SV$!FOO==FOO .SEE BITMAC
.ELSE SV$!FOO==1,,525252
EXPUNGE FOO
TERMIN
BITMAC AS,AS. ;LH ASARS
BITMAC TTS,TTS.,[1,,725252] ;LH TTSARS
BITMAC FBT,FBT. ;LH F.MODE WORD IN FILE ARRAYS
BITMAC RS.,RS. ;FOR READER SYNTAX BITS
BITMAC RS%,RS%,525252 ;READER SYNTAX BITS, LH SHIFTED INTO RH
BITMAC IB,IB.,[525252,,525252] ;WORD 1 INTERRUPT BITS
BITMAC %TB,%TB,SV$%TB ;LH .TTY USER VARIABLE
BITMAC %TI,%TI,SV$%TI ;LH TTY IOCHNM BITS (SOME PER-IOT)
BITMAC %TJ,%TJ,SV$%TJ
BITMAC %TX,%TX,SV$%TX ;RH TTY CHARACTER BITS
BITMAC %TO,%TO,SV$%TO ;LH TTYOPT VARIABLE
BITMAC %TS,%TS,SV$%TS ;LH TTYSTS VARIABLE
BITMAC %TC,%TC,SV$%TC ;LH TTYCOM VARIABLE
BITMAC %TG,%TG,SV$%TG ;6-BIT BYTE TTYST1,TTYST2 GROUPS
BITMAC %TT,%TT,SV$%TT ;LH TTYTYP VARIABLE
BITMAC %PI,%PI,SV$%PI ;FULL WORD .PIRQC VARIABLE
BITMAC %PJ,%PJ,SV$%PJ ;LH .PIRQC VARIABLE
] ;END OF IF1
;
;;; MACRO FOR .FASL LOSERS WHO .INSRT THIS FILE TO USE
;;; IN PLACE OF THE "END" PSEUDO. THIS GENERATES AN "END"
;;; AFTER PERFORMING SOME CLEANUP. MANY SYMBOLS ARE EXPUNGED
;;; SO THAT .FASL FILES WILL NOT SPEND INFINITE TIME TRYING TO
;;; PASS THEM TO DDT.
DEFINE FASEND
IF2,[
EXPUNGE NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP
EXPUNGE LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX
EXPUNGE CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS
EXPUNGE NERINT NASCII
EXPUNGE %UDF %UBV %WTA %UGT %WNA %GCL %FAC %IOL
EXPUNGE %%UDF %%UBV %%WTA %%UGT %%WNA %%GCL %%FAC %%IOL
EXPUNGE ASAR TTSAR
EXPUNGE AS.SFA AS.JOB AS.FIL AS.RDT AS.OBA AS.SX AS.FX AS.FL AS.DB AS.CX
EXPUNGE AS.DX AS.GCP
EXPUNGE TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC
EXPUNGE TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D
EXPUNGE FI.EOF FO.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.GC
EXPUNGE F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.AP FBT.CC FBT.ND
EXPUNGE F.CHAN F.JFN F.FLEN F.FPOS F.DEV F.SNM F.PPN F.FN1 F.FN2
EXPUNGE F.RDEV F.RSNM F.RFN1 F.RFN2
EXPUNGE F.DIR F.FNM F.EXT F.VRS
EXPUNGE L.6DEV L.6DIR L.6FNM L.6EXT L.6VRS L.D6BT L.N6BT L.F6BT
EXPUNGE LOPOFA
EXPUNGE TI.ST1 TI.ST2 TI.ST3 TI.ST4 ATO.LC
EXPUNGE AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FO.RPL LONBFA
EXPUNGE FB.BFL FB.BVC FB.BYT FB.IBP FB.BP FB.CNT FB.HED FB.NBF
EXPUNGE FB.BWS FB.ROF FB.BUF
EXPUNGE J.INTF J.LFNM J.GC J.INTB J.STAD J.UIND LOJOBA J.SYMS J.CRUF
EXPUNGE SR.CAL SFCALI SR.WOM SR.UDL SR.FML SR.FUN SR.PNA SR.FUS SR.LEN
EXPUNGE SO.OPN SO.CLO SO.REN SO.DEL SO.TRP SO.PR1 SO.TYI SO.UNT SO.TIP
EXPUNGE SO.IN SO.EOF SO.TYO SO.OUT SO.FOU SO.RED SO.RDL SO.PRT SO.PRC
EXPUNGE SO.MOD SO.POS
EXPUNGE ST.LS ST.$FS ST.FX ST.FL ST.BGN ST.SY ST.SA ST.VAC ST.$PDLNM
EXPUNGE ST.$XM ST.$NXM ST.PUR ST.HNK ST.DB ST.CX ST.DX ST.
IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567
13456,234,345,234567,76543]
EXPUNGE LA!X FA!X
TERMIN
MACROLOOP NBITMACS,BTMC,*
] ;END OF IF2
END
TERMIN
;SYMVC SYMARGS SYMPNAME SY.ONE SY.LAP SY.PUR SY.CCN SY.OTC SY.ZER SY.
SUBTTL SYMBOL BLOCK-STRUCTURE DEFINITIONS
;;; FORMAT OF SYMBOL HEADER FOR BIBOP:
;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE.
;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF
;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA.
;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST
;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF
;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE
;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO.
;;; THE SYMBOL BLOCK IS 2 WORDS LONG:
;;; <VARIOUS BITS>,,<POINTER TO VALUE CELL>
;;; <ARGS PROPERTY>,,<PNAME LIST>
;;; THE "VARIOUS BITS" ARE:
;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON)
;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK)
;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK)
;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL
;;; 3.6 ONE IFF COMPILED CODE REFERENCES BY OTHER THAN CALL UUO
;;; (IMPLIES 3.7 WHICH *MUST* ALSO BE ON)
;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE)
;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES,
;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS:
;;; 0 => NIL
;;; 777 => 777 (EFFECTIVELY INFINITY)
;;; N => N-1, N NOT 0 OR 777
;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777)
SYMVC==0 ;BITS,,VC
SYMARGS==1 ;ARGS PROP,,PNAME
SYMPNAME==1
SY.ONE==:777000 ;ONES (NO GOOD REASON!!)
SY.LAP==:400
SY.PUR==:200
SY.CCN==:100
SY.OTC==:040
SY.ZER==:037
SY.==:1,,<SY.ONE+SY.PUR+SY.OTC>
;ASAR TTSAR AS.SFA AS.JOB AS.FIL AS.RDT AS.OBA AS.DX AS.CX AS.DB AS.SX AS.FX AS.FL AS.GCP TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D
SUBTTL FORMAT OF ARRAYS
;;; ARRAYS ARE POINTED TO BY A TWO-WORD SAR (SPECIAL ARRAY CELL).
;;; SARS RESIDE IN A SPECIAL SPACE CALLED SAR SPACE.
ASAR==:0 ;SAR POINTER POINTS TO ASAR (CODE DEPENDS ON THIS)
TTSAR==:1 ;TTSAR COMES JUST AFTER IT
;;; THE FIRST WORD OF THE SAR, CALLED THE ASAR, POINTS TO THE ARRAY
;;; HEADER; PUSHJ'ING INDIRECTLY THOUGH IT GETS TO THE ARRAY
;;; SUBSCRIPT EVALUATION CODE. THE LEFT HALF, EXCLUDING THE
;;; INDIRECT AND INDEX BITS, CONTAINS VARIOUS BITS DESCRIBING
;;; THE TYPE OF THE ARRAY:
AS.SFA==:200000 ;SFA ARRAY
AS.JOB==:100000 ;JOB ARRAY
AS.FIL==:40000 ;FILE ARRAY
AS.RDT==:20000 ;READTABLE
AS.OBA==:10000 ;OBARRAY
AS.DX==:4000 ;DUPLEX ;THESE ARE
AS.CX==:2000 ;COMPLEX ; THE ACCESS
AS.DB==:1000 ;DOUBLE ; METHODS -
AS.SX==:400 ;S-EXPRESSION ; EXACTLY ONE
AS.FX==:200 ;FIXNUM ; SHOULD BE SET
AS.FL==:100 ;FLONUM ; IN EACH ASAR
AS.GCP==:40 ;GC SHOULD USE AOBJN PTR TO MARK ARRAY
;;; THE SECOND WORD, CALLED THE TTSAR, POINTS TO THE ARRAY DATA
;;; AND IS INDEXED BY ACCUMULATOR TT. ITS LEFT HALF, EXCLUDING
;;; AGAIN THE INDIRECT AND INDEX BITS, CONTAIN MORE INFORMATION
;;; ABOUT THE ARRAY:
TTS.CL==:40000 ;CLOSED FILE
TTS.IM==:2000 ;1 => IMAGE ;BOTH 0
TTS.BN==:1000 ;1 => BINARY (FIXNUM) ; => ASCII
TTS.TY==:400 ;0 => DSK-TYPE, 1 => TTY
TTS.IO==:200 ;0 => IN, 1 => OUT
TTS.CN==:100 ;COMPILED CODE NEEDS THIS SAR
TTS.GC==:40 ;USED AS MARK BIT BY GC
TTSDIM==:410300 ;BYTE POINTER FOR # OF DIMENSIONS (1-5)
TTS.1D==:100000 ;DEFINITIONS
TTS.2D==:200000 ; FOR SPECIFYING
TTS.3D==:300000 ; NUMBER OF
TTS.4D==:400000 ; ARRAY
TTS.5D==:500000 ; DIMENSIONS
;;; S-EXPRESSION ARRAYS HAVE THE FOLLOWING FORM:
;;; -<# WDS FOR GC MARK>,,<1ST WD OF DATA TO MARK>
;;; HEADER: JSP TT,<N>DIMS ;ASAR POINTS HERE; N=# OF DIMS
;;; <ADDRESS OF SAR> ;LH USED BY FLASH
;;; <DIMENSION 1>
;;; ...
;;; <DIMENSION N>
;;; DATA: <ENTRY 0>,,<ENTRY 1> ;TTSAR POINTS HERE
;;; ... ;DATA PACKED 2/WD
;;; <ENTRY X-1>,,<ENTRY X>
;;;
;;; THE FORMAT OF A NUMBER ARRAY IS AS FOLLOWS:
;;; <GC AOBJN PTR> ;PROBABLY MEANINGLESS
;;; HEADER: PUSH P,CFIX1 ;CFLOAT1 FOR A FLONUM ARRAY
;;; JSP TT,<N>DIMF ;N=# OF DIMS
;;; <ADDRESS OF SAR> ;LH USED BY FLASH
;;; <DIMENSION 1>
;;; ...
;;; <DIMENSION N>
;;; DATA: <ENTRY 0> ;TTSAR POINTS HERE
;;; <ENTRY 1> ;FULL-WORD DATA 1/WD
;;; ...
;;; <ENTRY X>
;;; THE AOBJN POINTER AT THE TOP OF EACH ARRAY IS MEANINGFUL ONLY
;;; IF THE AS.GCP BIT IS 1 IN THE ARRAY'S ASAR; IT INDICATES
;;; WHAT ENTRIES IN THE ARRAY GC SHOULD MARK. FOR S-EXPRESSION
;;; ARRAYS, THIS IS GENERALLY THE ENTIRE ARRAY; FOR OBARRAYS,
;;; IT INCLUDES THE BUCKETS BUT NOT THE SCO TABLE. FOR
;;; READTABLES, WHICH ARE OTHERWISE FIXNUM ARRAYS, UNDER NEWRD
;;; THE GC AOBJN POINTER INDICATES THAT THE LIST OF CHARACTER
;;; MACRO FUNCTIONS SHOULD BE MARKED.
;;; NOTE THAT IF SUCH AN AOBJN POINTER IS OF THE FORM <-N>,,<DATA>,
;;; THEN 2*N ENTRIES ARE MARKED; THE LEFT HALF IS THE NUMBER
;;; OF WORDS TO BE MARKED, WITH TWO ENTRIES PER WORD.
;;; CORRESPONDS TO ARRAY TYPE BITS IN ASAR'S.
;FI.EOF FO.EOP FJ.INT FI.BBC FI.BBF TI.BFN FT.CNS F.GC F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.EC FBT.SE FBT.FU FBT.ND FBT.SC F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 L.D6BT L.N6BT L.F6BT F.RDEV F.RFN1 F.RFN2 L.6DEV L.6DIR L.6FNM L.6EXT L.6VRS F.DEV F.DIR F.FNM F.EXT F.VRS L.D6BT L.N6BT L.F6BT LOPOFA TI.ST1 TI.ST2 ATO.LC AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FO.RPL LONBFA FB.BYT FB.BFL FB.BVC FB.IBP FB.BP FB.CNT FB.HED FB.NBF FB.BWS FB.BUF
SUBTTL FORMAT OF FILE ARRAYS
;;; FILE ARRAYS ARE ARRAYS WHICH HAVE THE AS.FIL BIT SET
;;; IN THE ASAR AND SOME EXTRA BITS IN THE TTSAR DESCRIBING
;;; THE TYPE OF ARRAY.
;;; A FILE ARRAY CONTAINS A NUMBER OF VARIABLES RELATED TO
;;; THE FILE, AND POSSIBLY A BUFFER FOR DATA.
;;; THE PREFIX OF EACH NAME OF A FILE ARRAY COMPONENT INDICATES THE
;;; TYPES OF FILE ARRAYS TO WHICH IT IS APPLICABLE. THUS TI.ST1
;;; IS ONLY FOR TTY INPUT FILE ARRAYS.
;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT
;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED.
.SEE GT3D
;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA
;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR).
FI.EOF==:0 ;EOF FUNCTION
FO.EOP==:0 ;END OF PAGE FUNCTION
FJ.INT==:0 ;INTERRUPT FUNCTION FOR USR DEVICE
FI.BBC==:1 ;BUFFERED BACK CHARS FOR ASCII FILES
; LEFT HALF: SINGLE CHAR (3.8=1 IF ANY,
; SO CAN DISTINGUISH ↑@ FROM NONE)
; RIGHT HALF: LIST OF CHARS FOLLOWING THE ONE
; IN THE LEFT HALF
.SEE $DEVICE
FI.BBF==:2 ;LIST OF BUFFERED BACK FORMS (NOT IMPLEMENTED)
TI.BFN==:3 ;BUFFER-FORWARD (PRESCAN) FUNCTION FOR READ
FT.CNS==:4 ;ASSOCIATED TTY FILE FOR OTHER DIRECTION
.SEE STTYCONS
;;; SLOTS 5, 6, AND 7 ARE RESERVED FOR EXPANSION.
F.GC==:10 ;NUMBER OF SLOTS GC SHOULD EXAMINE
F.MODE==:10 ;MODE BITS
FBT.CM==:400000 ;4.9 0=BUFFERED, 1=CHARMODE
FBT.SA==:200000 ;4.8 SAIL CHARACTER SET (OUTPUT ONLY)
FBT.CP==:100000 ;4.7 CURSORPOS WILL SUCCEED (?)
; ON ITS, REFLECTS %TOMVU (CAN MOVE UP)
.SEE OPNTO1
FBT.LN==:40000 ;4.6 HANDLE TTY IN LINE MODE
IFN SAIL+ITS, FBT.AP==:20000 ;4.5 OPENED IN APPEND MODE
SA% IT% FBT.AP==:0 ; THIS SHOULD WORK CORRECTLY
FBT.EC==:10000 ;4.4 OUTPUT TTY IN ECHO AREA (ITS ONLY)
FBT.SE==:2000 ;4.2 TTY CAN SELECTIVELY ERASE
FBT.FU==:1000 ;4.1 TTY SHOULD READ/PRINT FULL 12.-BIT
; CHARACTERS (FIXNUM MODE)
FBT.ND==:400 ;3.9 DON'T MEREGEF WITH DEFAULTF (NEVER LEFT ON
; IN OPTIONS WORD)
IT% FBT.CA==:0 ;THIS SHOULD WORK CORRECTLY
IT$ FBT.CA==:40 ;3.6 CLA DEVICE (ITS ONLY)
FBT.SC==:20 ;3.5 SCROLL MODE
;THE RIGHT HALF IS USED TO INDEX VARIOUS TABLES.
;1.4-1.3 0=ASCII, 1=FIXNUM, 2=IMAGE
;1.2 0=DSK, 1=TTY
;1.1 0=INPUT, 1=OUTPUT
F.CHAN==:11 ;I/O CHANNEL NUMBER
;FOR ALL IMPLEMENTATIONS, THIS IS THE INDEX INTO
.SEE CHNTB ; THE CHANNEL TABLE.
;FOR THE ITS AND D10 IMPLEMENTATIONS, IT IS
; ALSO THE I/O CHANNEL NUMBER.
20$ F.JFN==:12 ;THE JOB-FILE NUMBER FOR THIS FILE
F.FLEN==:13 ;THE LENGTH OF THE FILE, OR -1 IF RANDOM ACCESS IS IMPOSSIBLE.
; MAY NOT BE UP-TO-DATE ON AN OUTPUT FILE, BUT FILEPOS
.SEE FPOS5 ; UPDATES IT FIRST IN THIS CASE.
F.FPOS==:14 ;FILE POSITION
;FOR SINGLE MODE FILES, THIS IS THE ACTUAL FILE POSITION.
;FOR BLOCK MODE, THIS IS THAT OF THE BEGINNING OF
.SEE FB.BUF ; THE BUFFER IN THE FILE ARRAY, AND ONE
.SEE FB.B ; MUST LOOK AT FB.BVC AND FB.CNT
.SEE FB.CNT ; (OR WHATEVER) TO CALCULATE THE EXACT FILEPOS.
;THE POSITION IS MEASURED IN CHARACTERS FOR ASCII FILES,
; AND WORDS FOR FIXNUM FILES.
;THIS VALUE MAY BE GARBAGE IF F.FLEN IS NEGATIVE.
;;; SLOTS 15-17 ARE RESERVED.
IFN ITS+D10,[
;;; FROM F.DEV TO F.RFN2 ARE USED BY JOB ARRAYS ALSO.
;;; MUST HAVE (F.DEV, F.SNM/F.PPN, F.FN1, F.FN2) IN THAT ORDER.
;;; DITTO FOR (F.RDEV, F.RSNM/F.RPPN, F.RFN1, F.RFN2).
;;; THESE ARE THE NAME WHICH WERE GIVEN TO OPEN.
F.DEV==:20 ;DEVICE NAME
IT$ F.SNM==:21 ;SYSTEM NAME (SNAME)
10$ F.PPN==:21 ;PROJECT-PROGRAMMER NUMBER
F.FN1==:22 ;FILE NAME 1
F.FN2==:23 ;FILE NAME 2 (D10: EXTENSION)
L.D6BT==:2 ;LENGTH OF DEVICE/DIRECTORY "SIXBIT" FORM
L.N6BT==:2 ;LENGTH OF FILE NAMES IN "SIXBIT" FORM
L.F6BT==:L.D6BT+L.N6BT ;LENGTH OF TOTAL FILE SPECIFICATION IN "SIXBIT" FORM
;;; THESE ARE THE NAMES RETURNED BY THE TRUENAME FUNCTION.
F.RDEV==:24 ;"REAL" DEVICE NAME
IT$ F.RSNM==:25 ;"REAL" SYSTEM NAME
10$ F.RPPN==:25 ;"REAL" PPN
F.RFN1==:26 ;"REAL" FILE NAME 1
F.RFN2==:27 ;"REAL" FILE NAME 2
] ;END OF IFN ITS+D10
IFN D20,[
;;; FOR D20, "SIXBIT" FORM IS REALLY AN ASCIZ STRING.
L.6DEV==:8 ;LENGTH OF DEVICE NAME IN "SIXBIT" FORM
L.6DIR==:8 ;LENGTH OF DIRECTORY NAME
L.6FNM==:8 ;LENGTH OF FILE NAME
L.6EXT==:8 ;LENGTH OF EXTENSION (TYPE)
L.6VRS==:2 ;LENGTH OF VERSION (GENERATION)
;;; THESE ARE THE NAMES WHICH WERE GIVEN TO OPEN.
F.DEV==:20 ;DEVICE NAME (OR LOGICAL NAME)
F.DIR==:F.DEV+L.6DEV ;DIRECTORY
F.FNM==:F.DIR+L.6DIR ;FILE NAME
F.EXT==:F.FNM+L.6FNM ;EXTENSION
F.VRS==:F.EXT+L.6EXT ;VERSION
L.D6BT==:L.6DEV+L.6DIR ;LENGTH OF DEVICE/DIRCTORY "SIXBIT"
L.N6BT==:L.6FNM+L.6EXT+L.6VRS ;LENGTH OF FILE NAMES
L.F6BT==:L.D6BT+L.N6BT ;LENGTH OF TOTAL FILE SPECIFICATION
;;; THE "REAL" FILE NAMES ARE NOT STORED, BUT FETCHED BY JSYS EACH TIME.
] ;END OF IFN D20
LOPOFA==:70 .SEE ALFILE ;LENGTH OF PLAIN OLD FILE ARRAY
IFL LOPOFA-<F.DEV+L.F6BT>, WARN [DEFINITION OF LOPOFA IS TOO SMALL]
IFN ITS+D20+SAIL,[
;;; FOR ITS, THESE ARE TTYST1 AND TTYST2 FOR GIVING TO TTYSET.
;;; FOR D20, THESE ARE THE CCOC WORDS FOR GIVING TO SFCOC.
;;; FOR SAIL, THESE ARE THE ACTIVATION WORDS FOR SETACT.
TI.ST1==:LOPOFA+0 ;TTY STATUS WORD 1
TI.ST2==:LOPOFA+1 ;TTY STATUS WORD 2
IT% TI.ST3==:LOPOFA+2 ;TTY STATUS WORD 3
IT% TI.ST4==:LOPOFA+3 ;TTY STATUS WORD 4
] ;END OF ITS+D20+SAIL
ATO.LC==:LOPOFA+4 ;LAST CHARACTER FLAG FOR ASCII OUTPUT:
;ZERO: NORMAL STATE.
;POSITIVE: LAST CHARACTER OUTPUT WAS A SLASH,
; SO THE AUTOMATIC TERPRI SHOULD BE INHIBITED.
;NEGATIVE: LAST CHARACTER OUTPUT WAS A <CR>,
; SO IT MAY BE NECESSSARY TO SUPPLY A <LF>.
AT.CHS==:LOPOFA+5 ;CHARPOS
AT.LNN==:LOPOFA+6 ;LINENUM
AT.PGN==:LOPOFA+7 ;PAGENUM
FO.LNL==:LOPOFA+10 ;LINE LENGTH
;NORMALLY INITIALIZED TO 1 LESS THAN THE ACTUAL WIDTH
; OF THE DEVICE TO ALLOW FOR SLASH OVERRUN.
.SEE STERPRI ;MAY BE NEGATIVE, IN WHICH CASE THE
; MAGNITUDE IS THE ACTUAL VALUE.
FO.PGL==:LOPOFA+11 ;PAGE LENGTH
FO.RPL==:LOPOFA+12 ;"REAL" PAGEL FOR TTYS
;;; SLOTS 13-17 ARE RESERVED FOR EXPANSION.
LONBFA==:LOPOFA+20 ;LENGTH OF NON-BUFFERED FILE ARRAY
;;; EVERYTHING AFTER THIS IS ONLY FOR FILES WITH BUFFERS
FB.BYT==:LONBFA+0 ;NUMBER OF DATA BYTES PER WORD
FB.BFL==:LONBFA+1 ;LENGTH OF BUFFER IN BYTES
FB.BVC==:LONBFA+2 ;# VALID CHAARS IN BUFFER (ONLY INPUT FILES)
IFN ITS+D20,[
FB.IBP==:LONBFA+3 ;INITIAL BUFFER BYTE POINTER (RELOC)
FB.BP==:LONBFA+4 ;CURRENT BUFFER BYTE POINTER (RELOC)
FB.CNT==:LONBFA+5 ;COUNT OF REMAINING BYTES IN BUFFER
] ;END OF ITS+D20
IFN D10,[
FB.HED==:LONBFA+3 ;ADDRESS OF 3-WORD BUFFER RING HEADER
FB.NBF==:LONBFA+4 ;NUMBER OF BUFFERS
FB.BWS==:LONBFA+5 ;SIZE OF BUFFER IN WORDS (NOT COUNTING BUFFER HEADER)
SA$ FB.ROF==:LONBFA+6 ;(NEGATIVE) RECORD OFFSET IN BYTES, I.E. FILEPOS
; OF THE PHYSICAL BEGINNING OF THE FILE
] ;END OF IFN D10
FB.BUF==:LONBFA+10 ;BEGINNING OF BUFFER
;FOR ITS AND D20, THE DATA BUFFER BEGINS HERE.
;FOR D10, THE BUFFER RING STRUCTURE BEGINS HERE.
;FOR TTY INPUT FILES, THE "BUFFER" IS AN ARRAY
; OF INTERRUPT FUNCTIONS FOR EACH ASCII CHARACTER.
;J.INTF J.CINT J.LFNM J.CRUFT J.GC J.INTB J.STAD J.UIND LOJOBA J.SYMS
SUBTTL FORMAT OF JOB ARRAYS
IFN ITS,[
;;; JOB ARRAYS ARE ARRAYS WHICH HAVE THE AS.JOB BIT SET
;;; IN THE ASAR. THE TTS.CL BIT IS RELEVANT HERE ALSO,
;;; INDICATING A CLOSED JOB ARRAY.
;;; THE ARRAY CONTAINS VARIOUS DATA ASSOCIATED WITH THE JOB.
;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT
;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED.
;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA
;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR).
J.INTF==:0 ;INTERRUPT FUNCTION (NEEDED BY INT SYSTEM)
J.CINT==:1 ;CHANNEL INTERRUPT FUNCTION
J.LFNM==:2 ;LOAD FILE NAMELIST?
J.CRUFT==:3 ;RANDOM CRUFT (USUALLY PROPERTY LIST)
J.GC==:4 ;NUMBER OF SLOTS GC SHOULD EXAMINE
;SLOTS 3-12 RESERVED
;;; F.DEV THROUGH F.RFN2 (12 TO 21) APPLY TO JOB ARRAYS ALSO.
J.INTB==:LOPOFA+0 ;INTERRUPT BIT, OR ZERO FOR FOREIGN JOB
J.STAD==:LOPOFA+1 ;START ADDRESS
J.UIND==:LOPOFA+2
LOJOBA==:FB.BUF
J.SYMS==:FB.BUF ;START OF SYMBOL TABLE, IF ANY
] ;END OF IFN ITS
;SR.CAL SFCALI SR.WOM SR.UDL SO.OPN SO.CLO SO.REN SO.DEL SO.TRP SO.PR1 SO.TYI SO.UNT SO.TIP SO.IN SO.EOF SO.TYO SO.OUT SO.FOU SO.RED SO.RDL SO.PRT SO.PRC SO.MOD SO.POS SR.FML SR.FUN SR.PNA SR.FUS SR.LEN STPFL NM
IFE SFA, SFCALI==-1
IFN SFA,[
SUBTTL FORMAT OF SFA OBJECTS
;;; AN SFA OBJECT HAS THE AS.SFA BIT SET IN THE ASAR. TTS.CL IS IGNORED.
;;; THE FOLLOWING ARE INDICIES INTO THE SFA ARRAY AND ARE UNMARKED FROM:
SR.CAL==:0 ;THE LISP CALL UUO XCT'ED TO INVOKE THE SFA FUNCTION
SFCALI==:SR.CAL ;FOR COMPILED CODE
SR.WOM==:1 ;WHICH-OPERATIONS MASK: ENCODED MASK OF THE OPERATIONS THAT
; THE SFA CAN PERFORM. USED FOR QUICK TESTING IN CERTAIN
; DISPATCH CASES. BITS AS FOLLOWS:
SR.UDL==:2 ;USER DATA LENGTH
;;; ***NOTE: THE HALVNESS OF THE BITS MUST NOT CHANGE ***
;LH BITS
SO.OPN==:400000 ;OPEN
SO.CLO==:200000 ;CLOSE
SO.REN==:100000 ;RENAMEF
SO.DEL==:040000 ;DELETEF
SO.TRP==:020000 ;TERPRI
SO.PR1==:010000 ;PRIN1
SO.TYI==:004000 ;TYI
SO.UNT==:002000 ;UNTYI
SO.TIP==:001000 ;TYIPEEK
SO.IN==:000400 ;IN
SO.EOF==:000200 ;EOFFN
SO.TYO==:000100 ;TYO
SO.OUT==:000040 ;OUT
SO.FOU==:000020 ;FORCE-OUTPUT
SO.RED==:000010 ;READ
SO.RDL==:000004 ;READLINE
SO.PRT==:000002 ;PRINT
SO.PRC==:000001 ;PRINC
;RH BITS
SO.MOD==:400000 ;FILEMODE
SO.POS==:200000 ;FILEPOS
SR.FML==:3 ;FIRST MARKED LOCATION
SR.FUN==:3 ;RH IS SFA FUNCTION
SR.PNA==:4 ;RH IS PRINTNAME
SR.FUS==:5 ;LH IS FIRST USER SLOT
SR.LEN==:5 ;NUMBER OF WORDS NEEDED BY THE SYSTEM
] ;END IFN SFA
;;@ END OF DEFNS 173
;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT
;;@ MACS 68 LOTSA MOBY MACROS
;;; ***** MACLISP *** RANDOM MIDAS MACROS FOR USE IN LISP SOURCE *
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL RANDOM MACROS
;;; MACRO TO REMOVE SYMBOLS OF THE FORM "GXXXXX"
DEFINE GEXPUN
DEFFLUSH
.GSSET 0
STPFL==0
.TAG FOO FLUSH
IFE STPFL, .GO FOO
TERMIN
DEFINE DEFFLUSH \SYM
DEFINE FLUSH \ZZX
IFSE SYM,ZZX, STPFL==1
EXPUNGE ZZX
TERMIN
TERMIN
DEFINE HAOLNG NM,N
RADIX 2
NM==HAOWNG \N
RADIX 8
TERMIN
DEFINE HAOWNG A
.LENGTH /A/
TERMIN
DEFINE MAYBE DEF
IF1,[
IRPS SYM,,[DEF]
IFNDEF SYM, DEF
.ISTOP
TERMIN
]
TERMIN
DEFINE TBLCHK START,LENGT
IFN .-<START>-<LENGT>, WARN [WRONG LENGTH TABLE]
TERMIN
;
;;; "POP IMMEDIATE" MACRO TRIES TO DECREMENT A PDL POINTER IN THE BEST WAY.
DEFINE POPI <AC,N>
IFN KL10, ADJSP AC,-<N> .STOP
IFDEF R70, IFDEF LR70, IFL <N>-LR70, SUB AC,R70+<N> .STOP
SUB AC,[<N>,,<N>]
TERMIN
;;; "PUSH N SLOTS" MACRO PUSHES ZERO WORDS ONTO A PDL.
DEFINE PUSHN <AC,N>
IFE <N>, .STOP
IFE <N>-1, PUSH AC,R70 .STOP
IFE AC-P,{
PUSHN1 AC,N,NPUSH
.STOP}
IFE AC-FXP,{
PUSHN1 AC,N,0PUSH
.STOP}
IFE AC-FLP,{
PUSHN1 AC,N,0.0PUSH
.STOP}
WARN [PUSH AC,N UNKNOWN PDL]
TERMIN
DEFINE PUSHN1 <AC,M,XPUSH>
IFLE <M>-N!XPUSH, JSP T,XPUSH-<M> .STOP
JSP T,XPUSH-N!XPUSH
PUSHN1 AC,<M-N!XPUSH>,XPUSH
TERMIN
;%HISEG %LOSEG CURSTD %LOSEG %HISEG CURSTD
SUBTTL $LOSEG, $HISEG,
IFN D10,[
IFN HISEGMENT,[
DEFINE $LOSEG ;MACRO TO SWITCH TO LOW SEGMENT FOR 2SEG ASSEMBLY
IFN %LOSEG+1,[
%HISEG==.-HILOC
LOC FIRSTLOC+%LOSEG
%LOSEG==-1
CURSTD==STDLO
] ;END OF IFN %LOSEG+1
.ELSE WARN [ALREADY IN LOW SEGMENT]
TERMIN
DEFINE $HISEG ;MACRO TO SWITCH TO HIGH SEGMENT FOR 2SEG ASSEMBLY
IFN %HISEG+1,[
%LOSEG==.-FIRSTLOC
LOC HILOC+%HISEG
%HISEG==-1
CURSTD==STDHI
] ;END OF IFN %HISEG+1
.ELSE WARN [ALREADY IN HIGH SEGMENT]
TERMIN
] ;END IFN HISEGMENT
IFE HISEGMENT,[
DEFINE $LOSEG
TERMIN
DEFINE $HISEG
TERMIN
] ;END IFE HISEGMENT
] ;END OF IFN D10
;
SUBTTL PIONAGAIN, PIPAUSE, PION, TICCMAP
IFN ITS,[
DEFINE PIPAUSE ;DISABLE INTERRUPT SYSTEM
.SUSET PIHOLD
TERMIN
DEFINE PIONAGAIN
.SUSET PINBL
TERMIN
DEFINE PION
.SUSET PINBL
TERMIN
] ;END OF IFN ITS
IFN D10\D20,[
DEFINE PIPAUSE
PUSHJ P,DALINT
TERMIN
DEFINE PIONAGAIN
PUSHJ P,REAINT
TERMIN
DEFINE PION
PUSHJ P,ENBINT
TERMIN
] ;END OF IFN D10\D20
IFN D20,[
;DO THE "BODY' WITH "CODE" SUCCESSIVELY SET TO TERMINAL-INTERRUPT-CONTROL OPTIONS
DEFINE TICMAP {BODY}
IRP CODE,,[CB,CD,CG,CW,CX,CZ,CA,CV,CE,CF]
BODY
TERMIN
TERMIN
] ;END OF IFN D20
;ZZZ ZZZ
SUBTTL FUMBLE, STUMBLE, AND GRUMBLE
DEFINE FUMBLE FF,RIDER,SPECS ;FOR SPACES
STUMBLE FUMBLE,FF,RIDER,0,SEGSIZ,[SPECS]
TERMIN
DEFINE GRUMBLE PDL,RIDER,SPECS ;FOR PDLS
STUMBLE GRUMBLE,PDL,RIDER,20,100,[SPECS]
TERMIN
DEFINE STUMBLE NAME,FF,RIDER=[IFE 0],LO,HI,%SPECS
ZZZ==0
IRP SPEC,,[%SPECS]
IRP COND,VALS,[SPEC]
IFN COND,[
IRP M,,[MIN,MAX]Q,,[LO,HI]V,,VALS
RIDER,[
IFL V-Q, M!!FF==:Q
.ELSE M!!FF==:V
]
.ELSE M!!FF==:0
TERMIN
ZZZ==ZZZ+1
]
.ISTOP
TERMIN
TERMIN
IFN ZZZ-1, WARN \ZZZ,[ SPECS SUCCEEDED FOR NAME FF]
EXPUNGE ZZZ
TERMIN
;PGTPMK NPGTPS
SUBTTL PGBOT, [PGTOP], PAGEUP, SEGUP, SPCBOT, SPCTOP
;;; NOTE THAT PGBOT DEFINES PGTOP FOR THE NEXT USE, WHILE
;;; PGTOP IS AUTO-EXPUNGING (AND VICE VERSA).
DEFINE DPGBOT
DEFINE PGBOT SPC
PGTPMK==.
DEFINE PGBOT SPC1
WARN [ILLEGAL PGBOT SPC1]
TERMIN
DEFINE PGTOP SPC1,CRUFT
IFSN SPC1,SPC, WARN [PGTOP SPC1 DOESN'T MATCH PGBOT SPC]
CONC CPG,\NPGTPS,: CONSTANTS
CONC ECPG,\NPGTPS,::
PGTOP1 \NPGTPS,\.-PGTPMK,[CRUFT]
NPGTPS==NPGTPS+1
DPGBOT
TERMIN
TERMIN
DEFINE PGTOP SPC,CRUFT
WARN [ILLEGAL PGTOP SPC,CRUFT]
TERMIN
TERMIN
DPGBOT
DEFINE PGTOP1 N,SIZE,STUFF
PRINTX ≤ P!N: SIZE [STUFF]
≤
TERMIN
.XCREF PGTOP1
DEFINE PAGEUP
REL$ LOC .RL1+<<.-.RL1+CURSTD+PAGSIZ-1>&PAGMSK>-CURSTD
REL% LOC <<.-CURSTD+PAGSIZ-1>&PAGMSK>-CURSTD
TERMIN
DEFINE SEGUP PT
REL$ LOC .RL1+<<PT-.RL1+CURSTD+SEGSIZ-1>&SEGMSK>-CURSTD
REL% LOC <<PT+CURSTD+SEGSIZ-1>&SEGMSK>-CURSTD
TERMIN
;ZZY ZZ ZZX ZZY
DEFINE SPCBOT SPC
REL$ ZZ==.-.RL1
REL% ZZ==.
ZZY==.TYPE B!SPC!SG
IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[
IFN B!SPC!SG-., WARN [FORMERLY B!SPC!SG=]\B!SPC!SG,[, BUT NOW B!SPC!SG=]\ZZ
]
IFN <ZZ+CURSTD>&SEGKSM, WARN \ZZ+CURSTD,[=BAD BOUNDARY FOR B!SPC!SG]
B!SPC!SG==.
TERMIN
;;; NOTE WELL! ZZW MUST BE SAFE ACROSS THE SPCTOP MACRO
DEFINE SPCTOP SPC,TYP,CRUFT
ZZ==.
SEGUP .
ZZX==<.-B!SPC!SG>/SEGSIZ
ZZY==.TYPE N!SPC!SG
IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[
IFN N!SPC!SG-ZZX, WARN [FORMERLY N!SPC!SG=]\N!SPC!SG,[, BUT NOW N!SPC!SG=]\ZZX
]
N!SPC!SG==ZZX
IFL ZZX-5, SPCTP1 \ZZX,[CRUFT]\<.-ZZ>
IFGE ZZX-5, SPCTP2 \ZZX,[CRUFT]\<.-ZZ>
TERMIN
DEFINE SPCTP1 N,CRUFT,U
IRP Q,,[0,1,2,3,4]R,,[ZERO,ONE,TWO,THREE,FOUR]
IFE N-Q,[
PRINTX ≤ ***** R CRUFT SEGMENT≤
IFN N-1, PRINTX \S\
IFN U, PRINTX \ [U UNUSED WORDS]\
PRINTX \
\
]
IFE N-Q, .ISTOP
TERMIN
TERMIN
DEFINE SPCTP2 N,CRUFT,U
IRP Q,,[5,6,7,10,11,12,13,14,15,16,17,20,21,22
23,24,N]R,,[FIVE,SIX,SEVEN,EIGHT,NINE,TEN
ELEVEN,TWELVE,THIRTEEN,FOURTEEN,FIFTEEN,SIXTEEN,SEVENTEEN
EIGHTEEN,NINETEEN,TWENTY,N (OCTAL)]
IFE N-Q,[
PRINTX ≤ ***** R CRUFT SEGMENT≤
IFN N-1, PRINTX \S\
IFN U, PRINTX \ [U UNUSED WORDS]\
PRINTX \
\
]
IFE N-Q, .ISTOP
TERMIN
TERMIN
.XCREF SPCTP1 SPCTP2
;NPURTR NIOCTR
SUBTTL PURTRAP, IOCTRAP, 2DIF, AND INTPRO MACROS
;;; FEATURE FOR AUTOMATIC TRAPOUT ON PURE PAGE VIOLATIONS
;;; STANDARD USAGE IS TO REPLACE
;;; MOVEM X,Y ;COULD CAUSE PURE PAGE TRAP
;;; WITH
;;; PURTRAP PATCH-LOC,AC, MOVEM X,Y
;;; IF THE INSTRUCTION CAUSES A PURE PAGE VIOLATION,
;;; THEN THE PURE PAGE TRAP HANDLER WILL TRANSFER TO FOO,
;;; WITH ALL ACS, ETC. INTACT (HOPEFULLY), RATHER THAN
;;; ERRORING OUT, WHICH IS THE DEFAULT. SEE PURPGI.
;;; FOR DEC-10, THERE IS AN EXPLICIT CHECK FOR TRYING TO CLOBBER
;;; THE HISEG.
;;; A SIMILAR FEATURE FOR IOC TRAPS
;;; STANDARD USAGE IS:
;;;
;;; BAR: XCT D ;D HAS .IOT
;;; IOCTRAP TT,FOO,N ;N IS OPTIONAL
;;; <MORE CODE>
;;;
;;; IF THE INSTRUCTION AT BAR CAUSES AN IOC ERROR,
;;; THEN THE IOC ERROR CODE IS PUT INTO ACCUMULATOR TT,
;;; AND CONTROL TRANSFERRED TO FOO WITH ALL OTHER ACS INTACT.
;;; IF N IS GIVEN, ONLY IOC ERROR CODE N IS TRAPPED.
IFN ITS+D20,[
DEFINE PURTRAP X,B-INST
INST
PURTR1 \.-1,\NPURTR,D,X
NPURTR==NPURTR+1
TERMIN
DEFINE PURTR1 L,N,AC,X
DEFINE ZZP!N
CAIN AC,L
HRROI AC,X
TERMIN
TERMIN
;;; FOR COMMENTS ON 2DIF, SEE BELOW
DEFINE 2DIF INST,X,Y
<INST>\<,,<X>-<Y>>
TERMIN
] ;END OF IFN ITS+D20
DEFINE IOCTRAP AC,X,N
IOCTR1 \.-1,\NIOCTR,AC,X,N
NIOCTR=NIOCTR+1
TERMIN
DEFINE IOCTR1 L,N,AC,X,N
DEFINE ZZI!N
IFSN [N],[
CAIE D,N
JRST .+3
]
CAIN R,L
MOVE R,[SETZ X(AC)]
TERMIN
TERMIN
;N2DIF
IFN D10,[
DEFINE PURTRAP X,B-INST
HS$ CAIL B,HILOC
HS$ JRST X
INST
TERMIN
;;; FEATURE FOR TWO-SEGMENT DEC-10 ASSEMBLIES TO WIN ON THE
;;; MANY INSTRUCTIONS IN LISP WHICH ARE OF THE FORM
;;; JRST FOO-BAR(X)
;;; WHERE FOO IS IN ONE SEGMENT AND BAR IN THE OTHER.
;;; THE CORRECT WAY TO WRITE THE ABOVE INSTRUCTION IS
;;; 2DIF JRST (X),FOO,BAR
DEFINE 2DIF INST,X,Y
IFN %HISEG+1, 2DIF1 \.-HILOC,HILOC,[X][Y]\N2DIF
IFE %HISEG+1, 2DIF1 \.-FIRSTLOC,FIRSTLOC,[X][Y]\N2DIF
N2DIF==N2DIF+1
INST
TERMIN
;;; A COUPLE OF CROCKS:
;;; [1] THE .CRFON AND .CRFOFF IN ZZD!N INTERACT WITH
;;; THOSE IN THE MACROLOOP MACRO.
;;; [2] THE OFFSETS ALLOW ADDRESSES CONTAINING . IN
;;; THE 2DIF'ED INSTRUCTION (KNOCK PLASTIC).
;;; I.E. THE OFFSET F+L-. IS A HACK SO THAT
;;; ANY .'S IN X OR Y WILL REFER TO THE 2DIF'D
;;; INSTRUCTION AND NOT TO THE PLACE WHERE THE ZZD!N
;;; GETS EXPANDED.
DEFINE 2DIF1 L,F,X,Y,N
.CRFOFF
DEFINE ZZD!N
.CRFON
OFFSET F+L-.
MOVEI T,X
SUBI T,Y
OFFSET 0
.CRFOFF
HRRM T,F+L
TERMIN
.CRFON
TERMIN
;;; THE ZZD MACROS GET EXPANDED IN THE INIT ROUTINE.
] ;END OF IFN D10
;NPRO
DEFINE INTPRO W
REL$ PROENT \.-.RL1,W,\NPRO
REL% PROENT \.,W,\NPRO
TERMIN
DEFINE PROENT L,W,N
DEFINE PRO!N
REL$ W,,L+.RL1
REL% W,,L
TERMIN
NPRO==NPRO+1
TERMIN
DEFINE NOPRO ;BEGINS INTERVAL WITH NO INT PROTECTION
INTPRO INTOK
TERMIN
DEFINE SFXPRO ;CODE PROMISES TO RETURN THROUGH AN SFX CELL
INTPRO INTSFX
TERMIN
DEFINE XCTPRO ;FOLLOWING INSTRS MUST BE XCT'D BEFORE INT
INTPRO INTXCT
TERMIN
DEFINE BAKPRO ;MUST BACK UP TO HERE IF INT HAPPENS
INTPRO INTBAK
TERMIN
DEFINE SPECPRO H ;USED A SPECIALIZED PROTECTION ROUTINE
INTPRO H
TERMIN
;;; NO PROTECTION FOR ABSOLUTE LOCATIONS FROM 0 UP TO NEXT INTERVAL
DEFINE PRO0
INTOK,,0
TERMIN
;;; THE PRO MACROS ARE EXPANDED AT PROTB (Q.V.)
;ZZ ZZ ZZ GS SEGBYT LONUM HINUM PAGSIZ PAGMSK PAGKSM NPAGS NNUMTP NTYPES
SUBTTL ST AND GCST HACKERS
IFN PAGING,[
;;; THESE MACROS ACTUALLY FILL IN THE SEGMENT TABLES, FOR ITS ASSEMBLIES
DEFINE $ST SPC,BITS
IFN .-ST-<B!SPC!SG/SEGSIZ>,[
WARN [SEGMENT TABLE PHASE ERROR - TABLE LOC=]\.-ST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ
LOC ST+<B!SPC!SG/SEGSIZ>
]
IFN N!SPC!SG, $ST1 SPC,\N!SPC!SG,BITS
TERMIN
DEFINE $ST1 SPC,N,XBITS
ST.!SPC:
ZZ==0
IRP TYPE,,[LIST,FIXNUM,FLONUM,BIGNUM,SYMBOL,RANDOM,ARRAY]BB,,[LS,FX,FL,BN,SY,RN,SA]
IFN <XBITS>&BB,[
REPEAT N, <XBITS>,,Q!TYPE
ZZ==ZZ+1
]
TERMIN
IFN ZZ-1, WARN [IMPROPER TYPE BITS FOR SPC SPACE: ]\XBITS
TERMIN
;;; THERE ARE NO INITIAL HUNKS!!!
;;; THESE MACROS HAVE THEREFORE NOT BEEN HACKED FOR HUNKS!!!
DEFINE $GCST SPC,LINK,BTBP,BITS
IFSE LINK,L, L!SPC!SG==0
IFN .-GCST-<B!SPC!SG/SEGSIZ>,[
WARN [GCST PHASE ERROR - TABLE LOC=]\.-GCST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ
LOC GCST+<B!SPC!SG/SEGSIZ>
]
IFN N!SPC!SG, $GCST1 \N!SPC!SG,SPC,LINK,BTBP,BITS
TERMIN
DEFINE $GCST1 N,SPC,LINK,BTBP,BITS
GS.!SPC:
REPEAT N,[
ZZ==(BITS)
IFSE BTBP,B, ZZ==ZZ+BTB.←<5-SEGLOG>
.ALSO BTB.==BTB.+BTBSIZ
IFSE LINK,L, ZZ==ZZ+L!SPC!SG←<22-<SEGLOG-5>>
.ALSO L!SPC!SG==.-GCST
ZZ
]
TERMIN
] ;END OF IFN PAGING
IFE PAGING,[
;;; THIS MACRO MAKES UP THE CODE THAT INITIALIZES THE SEGMENT TABLES
DEFINE 10ST SPC,STENT=[$XM,,QRANDOM]GCENT=0,LINK,BITS
IFN N!SPC!SG,[
MOVEI T,B!SPC!SG
LSH T,-SEGLOG
MOVE TT,[STENT]
REPEAT N!SPC!SG, MOVEM TT,ST+.RPCNT(T)
IFN GCENT,[
MOVSI TT,GCENT
REPEAT N!SPC!SG,[
IFSN BITS,,[
HRRI TT,(AR1)
ADDI AR1,1
] ;END OF IFSN BITS,,
MOVEM TT,GCST+.RPCNT(T)
] ;END OF REPEAT N!SPC!SG
] ;END OF IFN GCENT
IFSN LINK,,[
IFG N!SPC!SG-1,[
HRLI T,-N!SPC!SG+1
DPB T,[SEGBYT,,GCST+1(T)]
AOBJN T,.-1
] ;END OF IFG N!SPC!SG-1
HRRZM T,LINK
] ;END OF IFSN LINK,,
] ;END OF IFN N!SPC!SG
TERMIN
] ;END OF IFE PAGING
;;; $<GS>T IN DDT IS GOOD FOR LOOKING AT GCST
GS==<777000,,>\<<1←<22-<SEGLOG-5>>>-1>
;;; FOR FETCHING LINK FIELD WITH A LDB
SEGBYT==<22-<SEGLOG-5>>←14+<22-SEGLOG>←6
;;@ END OF MACS 68
SA% LRCT==:NASCII+10 ;SPACE SUFFICIENT FOR CHARS AND SWITCHES
SA$ LRCT==:1010
10$ LIOBUF==:200 ;LENGTH OF STANDARD VANILLA I/O BUFFER
LONUM==400 ;MINIMUM MAGNITUDE OF LOWEST NEGATIVE INUM
HINUM==1000 ;MINIMUM MAGNITUDE OF LARGEST POSITIVE INUM
;SOME CODE ASSUMES HINUM IS AT LEAST 777
;MUCH CODE ASSUMES HINUM IS AT LEAST 177 (FOR ASCII CHARS)
IFN ITS, PAGLOG==:12 ;LOG2 OF PAGE SIZE
; (DAMN WELL BETTER BE 12 FOR ITS!!!
IFN D10, PAGLOG==:11 ; SOME CODE ASSUMES IT WILL BE 11 OR 12)
IFN D20, PAGLOG==:11
IFE D10*PAGING, MEMORY==:<1,,0> ;SIZE OF MEMORY!!!
IFN D10*PAGING, MEMORY==:776000 ;ON D10 SYSTEMS, CAN'T USE ALL OF MEMORY
PAGSIZ==:1←PAGLOG ;PAGE SIZE
PAGMSK==:<777777←PAGLOG>&777777 ;MASKS ADDRESSES TO PAGE BOUNDARY
PAGKSM==:PAGMSK#777777 ;MASKS WORD ADDRESS WITHIN PAGE
NPAGS==:MEMORY/PAGSIZ ;NUMBER OF PAGES IN MEMORY
NNUMTP==:2+BIGNUM+DBFLAG+CXFLAG+DBFLAG*CXFLAG ;NUMBER OF NUMBER TYPES
NTYPES==:3+HNKLOG+1+NNUMTP+1 ;NUMBER OF DATA TYPES, COUNTING RANDOM
;SEGSIZ SEGMSK SEGKSM NSEGS BTBSIZ SGS%PG BTSGGS ALPDL ALFXP ALFLP ALSPDL ALFXP ALFLP ALPDL ALSPDL
;;; IF1
SEGSIZ==:1←SEGLOG ;SEGMENT SIZE
SEGMSK==:<777777←SEGLOG>&777777 ;MASKS ADDRESSES TO SEGMENT BOUNDARY
SEGKSM==:SEGMSK#777777 ;MASKS WORD ADDRESS WITHIN SEGMENT
NSEGS==:MEMORY/SEGSIZ ;NUMBER OF SEGMENTS IN MEMORY
BTBSIZ==:SEGSIZ/40 ;SIZE OF BIT BLOCKS
;(ENOUGH BITS FOR A SEGMENT, 40 PER WORD)
SGS%PG==:NSEGS/NPAGS ;NUMBER OF SEGMENTS PER PAGE
BTSGGS==1 ;GUESS AT THE NUMBER OF INITIAL BIT SEGMENTS
IFN PAGING,[
ALPDL==4*PAGSIZ ;DEFAULT TOTAL PDL SIZES
ALFXP==4*PAGSIZ
ALFLP==1*PAGSIZ
ALSPDL==2*PAGSIZ
] ;END OF IFN ITS+D20
IFE PAGING,[
ALFXP==SEGSIZ ;DEFAULT TOTAL PDL SIZES
ALFLP==SEGSIZ
ALPDL==3000
ALSPDL==1400
] ;END OF IFN D10
;;; GROSSLY DETERMINE MIN AND MAX PARAMETERS FOR EACH SPACE AND PDL
FUMBLE FFS,,[[1,[0.25,40000]]]
FUMBLE FFX,,[[PAGING,[0.2,14000]],[PAGING-1,[0.25,3000]]]
FUMBLE FFL,,[[PAGING,[0.15,2*SEGSIZ]],[PAGING-1,[0.25,SEGSIZ]]]
FUMBLE FFD,IFN DBFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFC,IFN CXFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFZ,IFN DXFLAG,[[1,[0,SEGSIZ]]]
FUMBLE FFB,IFN BIGNUM,[[PAGING,[3*SEGSIZ/4,2*SEGSIZ]],[PAGING-1,[0.2,SEGSIZ]]]
FUMBLE FFY,,[[PAGING,[SEGSIZ/2,6000]],[PAGING-1,[SEGSIZ/2,3*SEGSIZ]]]
FUMBLE FFH,IFN HNKLOG,[[1,[0,2*SEGSIZ]]]
FUMBLE FFA,,[[1,[40,SEGSIZ]]]
GRUMBLE PDL,,[[1,[200,1400]]]
GRUMBLE SPDL,,[[1,[100,1400]]]
GRUMBLE FXP,,[[1,[200,1000]]]
GRUMBLE FLP,,[[1,[20,200]]]
;IB.ALARM IB.TIMER IB.PARITY IB.FLOV IB.PURE IB.PCPURE IB.SYSUUO IB.AT3 IB.AT2 IB.AT1 IB.DEBUG IB.RVIOL IB.CLI IB.PDLOV IB.LTPEN IB.MAR IB.MPV IB.SCLK IB.1PROC IB.BREAK IB.ILAD IB.IOC IB.VALUE IB.DOWN IB.ILOP IB.DMPV IB.AROV IB.42BAD IB.C.Z IB.TTY IB.PDLOV IB.MPV
;;; IF1
;;; ********** INTERRUPT BITS **********
IFN ITS,[
;;; THESE NAMES SHOULD BE PHASED OUT IN FAVOR OF THE ITS-STANDARD %PI SERIES.
;;; LISP SETS ITS INTERRUPT MASK (.MASK USET VARIABLE) ONLY FROM
;;; THE CONTENTS OF LOCATION IMASK, WHICH INITIALLY CONTAINS STDMSK.
;;; DEPOSITING DBGMSK THERE BEFORE STARTUP DISABLES ALL INTERRUPTS
;;; EXCEPT TTY AND PDL OVERFLOW, SO THAT DDT WILL TRAP ILOP, MPV, ETC.
IB.ALARM==200000,, ; REAL TIME CLOCK (ALARM CLOCK)
IB.TIMER==100000,, ; RUN TIME CLOCK
IB.PARITY==1000,, ;+ PARITY ERROR
IB.FLOV==400,, ; FLOATING OVERFLOW
IB.PURE==200,, ;+ PURE PAGE TRAP (WRITE INTO READ-ONLY)
IB.PCPURE==100,, ;+ PURE INSTRUCTION FETCH FROM IMPURE
IB.SYSUUO==40,, ;+ SYS UUO TRAP
IB.AT3==20,, ; ARM TIP BREAK 3
IB.AT2==10,, ; ARM TIP BREAK 2
IB.AT1==4,, ; ARM TIP BREAK 1
IB.DEBUG==2,, ; SYSTEM BEING DEBUGGED
IB.RVIOL==1,, ;+ RESTRICTION VIOLATION (?)
IB.CLI==400000 ; CORE LINK INTERRUPT
IB.PDLOV==200000 ; PDL OVERFLOW
IB.LTPEN==100000 ; LIGHT PEN INTERRUPT
IB.MAR==40000 ;+ MAR INTERRUPT
IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION
IB.SCLK==10000 ; SLOW CLOCK TICK (.5 SEC)
IB.1PROC==4000 ;* SINGLE INSTRUCTION PROCEED
IB.BREAK==2000 ;* .BREAK EXECUTED
IB.ILAD==1000 ;+ ILLEGAL USER ADDRESS
IB.IOC==400 ;+ I/O CHANNEL ERROR
IB.VALUE==200 ;* .VALUE EXECUTED
IB.DOWN==100 ; SYSTEM GOING DOWN OR BEING REVIVED
IB.ILOP==40 ;+ ILLEGAL INSTRUCTION OPERATION
IB.DMPV==20 ;+ DISPLAY MEMORY PROTECTION VIOLATION
IB.AROV==10 ; ARITHMETIC OVERFLOW
IB.42BAD==4 ;* BAD LOCATION 42
IB.C.Z==2 ;* ↑Z TYPED WHEN THIS JOB HAD TTY
IB.TTY==1 ; INTERRUPT CHAR TYPED ON TTY
] ;END OF IFN ITS
IFN D10,[
IB.PDLOV==AP.POV ; PDL OVERFLOW
IB.MPV==AP.ILM ;+ MEMORY PROTECTION VIOLATION
SA% STDMSK==AP.REN+AP.POV+AP.ILM+AP.NXM+AP.PAR
SA$ STDMSK==<404,,230000>
] ;END OF IFN D10
;;; ********** I/O CHANNEL ASSIGNMENTS **********
;;; PAGE 376 IS RESERVED FOR COPYING (SEE IP1), AND 377 FOR DISUSE.
;;; (THE DISUSE AS TO DO WITH AN OLD HARDWARE BUG IN BLT.)
;;; ON AI, PAGE 375 IS FOR MAPPING PAGE 0 OF THE DISPLAY SLAVE.
IT$ P6=MEMORY-3*PAGSIZ ;PAGE 0 OF PDP6 SLAVE IS MAPPED INTO PDP-10 MEMORY
] ;END OF IF1
;TOPN BOTN NPURTR NIOCTR N2DIF NPRO %LOSEG %HISEG FIRSTLOC STDLO STDHI CURSTD STDLO STDHI CURSTD LISPSW SUSFLS
SUBTTL FIRST LOCATIONS, UUO AND INTERRUPT VECTORS
;IFE <ITS+TENEX>*USELESS, NPGTPS==0
IFE 0, NPGTPS==0
TOPN==0
BOTN==0
.XCREF TOPN BOTN
NPURTR==0
NIOCTR==0
.XCREF PURTR1 NPURTR NIOCTR
N2DIF==0
NPRO==0+1 ;NUMBER OF INTERRUPT PROTECTION REGIONS
;NOTE DEFN OF PRO0 IN MACS FILE
.XCREF NPRO
IFN D10,[
HS$ .DECTWO ;DEC TWO-SEGMENT RELOC OUTPUT
HS% .DECREL ;ONE SEGMENT ASSEMBLY
IFN PAGING, LOC 140 ;FOR PAGING ASSEMBLY NEED ABSOLUTE ADDRESSING
%LOSEG==-1 ;INITIALLY START IN LOW SEGMENT
%HISEG==0 ;START AT 0 RELATIVE TO HIGH SEG ORIGIN
] ;END OF IFN D10
IFN ITS, IFDEF .SBLK, .SBLK ;EVENTUALLY FLUSH "IFDEF .SBLK"
20$ .DECREL ;FOR TOPS-20 NEED DEC RELOCATABLE FORMAT
20$ LOC 140 ;BUT FORCE ABSOLUTE ADDRESSING
.YSTGWD ;STORAGE WORDS ARE OKAY NOW
FIRSTLOC:
IFN D10,[
HS$ HILOC==.+400000 ;HISEG STARTS AT 400000
HS% HILOC==.
;;; FOR DEC-10, FIRSTLOC AS LOADED WITH RELOCATION MUST BE
;;; STDLO+M*SEGSIZ
;;; AND SIMILARLY HILOC WHEN LOADED MUST BE
;;; STDHI+N*SEGSIZ
;;; FOR INTEGRAL M AND N. INIT WILL ENFORCE THIS IN ORDER
;;; TO PRESERVE SEGMENT BOUNDARIES CORRECTLY.
;;; CURSTD IS THE STDXX FOR WHICHEVER IS THE CURRENT SEGMENT.
STDLO==140 ;SIZE OF JOB DATA AREA
STDHI==10 ;VESTIGIAL JOB DATA AREA
CURSTD==STDLO .SEE $LOSEG
] ;END OF IFN D10
IFN PAGING,[
STDLO==0
STDHI==0
CURSTD==0
] ;END OF IFN PAGING
IFN PAGING, BZERSG==0 ;BEGINNING OF "ZERO" SEGMENT(S)
IFE PAGING, BZERSG==FIRSTLOC-STDLO
LOC 41
JSR UUOH ;UUO HANDLER
10X WARN [TENEX INTERRUPT VECTOR?]
LOC FIRSTLOC
JRST GOINIT
LISPSW: %ALLOC ;ALLOC CLOBBERS TO BE "LISP"
SUSFLS: TRUTH ;NON-NIL MEANS FLUSH SHARABLE PAGES BEFORE SUSPENDING
;TWENTY THIRTY FORTY UUOGLEEP JPCSAV
IFN ITS,[
TWENTY==:20 ;VARIOUS PLACES OFFSET FROM TWENTY ARE USED BY DDT
THIRTY==:TWENTY+10 ;RECALL THAT THE LEFT HALF OF .40ADDR IS THE ".20ADDR"
;;; ADDRESSES IN THE 20 BLOCK, SWIPED FROM DDT ORDER
;;; 25 HOLDS "." DURING A USER TYPEOUT INSTRUCTION
;;; 26 CONDITIONAL BREAKPOINT INSTRUCTION
;;; 27-30 .BREAK 16,'S FOR RETURNING FROM 26
;;; 31 INSTRUCTION FOR BREAKPOINT WHICH DIDN'T BREAK
;;; 32-33 JRST'S TO PROGRAM FROM 31, OR DATA FOR INSTRUCTION IN 31
;;; 34 INSTRUCTION BEING ≠X'D
.SEE MEMERR
.SEE UUOGL2
;;; 35-36 .BREAK 16,'S FOR RETURNING FROM 34
.SEE $XLOST
.SEE UUOGL2
;;; 37 HOLDS ≠Q DURING A USER TYPEOUT INSTRUCTION
.SEE PSYM1
FORTY: 0 ;.40ADDR USER VARIABLE POINTS HERE
JSR UUOGLEEP ;SYSTEMIC UUO HANDLER
-LINTVEC,,INTVEC ;SYSTEMIC INTERRUPT HANDLER
;;; THAT'S SYSTEMIC, NOT NECESSARILY SYSTEMATIC!!!
;;; ITS PASSES THE BUCK TO THE USER ON UUO'S 0 AND 50-77.
;;; THEY TRAP THROUGH THE .40ADDR, NOT NECESSARILY 40;
;;; SINCE LISP TREATS THESE AS ERRORS, WE CAN AFFORD TO SAVE
;;; THE JPC AND OTHER GOODIES HERE.
UUOGLEEP: 0
.SUSET [.RJPC,,JPCSAV]
JRST UUOGL1
] ;END OF IFN ITS
JPCSAV: 0
;NSFC NSFC NSFC
SUBTTL SFX HACKERY
;;; SFX MACRO TELLS WHERE A LONG PIECE OF SEMI-CRITICAL (MAY BE QUIT
;;; OUT OF, BUT MUST NOT PERMIT USER INTERRUPTS IN) CODE MAY BE MUNGED
;;; IF INTERRUPTED IN THE MIDDLE SO THAT WHEN DONE IT WILL RETURN TO
;;; THE INTERRUPT HANDLER. SUCH CODE INCLUDES ARRAY SUBSCRIPT
;;; COMPUTATIONS (SINCE AN INTERRUPT COULD DISPLACE THE ARRAY)
;;; AND ALL CODE WHICH MODIFIES THE SPECIAL PDL.
NSFC==0 ;COUNTER FOR MACRO SFX
.XCREF NSFC
IFE PAGING,[
DEFINE SFX A/
SFSTO \.-FIRSTLOC,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
FIRSTLOC+PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN PAGING
IFN PAGING,[
DEFINE SFX A/
SFSTO \.,\NSFC,[A]
NSFC==NSFC+1
A
TERMIN
DEFINE SFSTO PT,NM,IN
DEFINE ZZM!NM
PT
TERMIN
DEFINE ZZN!NM
IN
TERMIN
TERMIN
] ;END OF IFN PAGING
;;; THE ZZM AND ZZN MACROS ARE EXPANDED AT SFXTBL (Q.V.)
;UNBND2 ABIND3 SETXIT SPECX AYNVSFX 1DIMS ARYGET ARYGT4 ARYGT8 1DIMF ANYGET 1DIMD ADYGET 1DIMZ AZYGET SPSV
;;; **** ALL USES OF THE SFX MACRO MUST APPEAR ON THIS PAGE ****
SFXPRO
UNBND2: MOVE TT,(SP)
MOVEM TT,SPSV ;ABOUT LOADING TT WITH SPSV, SEE UNBIND
MOVE TT,UNBND3
SFX POPJ P,
ABIND3: PUSH SP,SPSV
SFX POPJ P,
SETXIT: SUB SP,R70+1
SFX JRST (T)
SPECX: PUSH SP,SPSV
SFX JRST (T)
AYNVSFX: ;XCT'ED BY AYNVER
SFX %WTA (D)
1DIMS: JSP T,AYNV1 ;1-DIM S-EXP ARRAYS COME HERE
ARYGET: ROT R,-1 ;COMMON S-EXP ARRAY ACCESS ROUTINE
ADDI TT,(R)
ARYGT4: JUMPL R,ARYGT8
HLRZ A,(TT)
SFX POPJ P,
ARYGT8: HRRZ A,(TT)
SFX POPJ P,
1DIMF: JSP T,AYNV1 ;1-DIM FULLWORD ARRAYS COME HERE
ANYGET: ADDI TT,(R) ;COMMON FULLWORD ARRAY ACCESS ROUTINE
MOVE TT,(TT)
SFX POPJ P,
IFN DBFLAG+CXFLAG,[
1DIMD: JSP T,AYNV1 ;1-DIM DOUBLEWORD ARRAYS COME HERE
ADYGET: LSH R,1 ;COMMON DOUBLEWORD ARRAY ACCESS ROUTINE
ADDI TT,(R)
KA MOVE D,1(TT)
KA MOVE TT,(TT)
KIKL DMOVE TT,(TT)
SFX POPJ P,
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
1DIMZ: JSP T,AYNV1 ;1-DIM FOUR-WORD ARRAYS COME HERE
AZYGET: LSH R,2 ;COMMON FOUR-WORD ARRAY ACCESS ROUTINE
ADDI TT,(R)
KA MOVE R,(TT)
KA MOVE F,1(TT)
KA MOVE D,3(TT)
KA MOVE TT,2(TT)
KIKL DMOVE R,(TT)
KIKL DMOVE TT,2(TT)
SFX POPJ P,
] ;END OF IFN DXFLAG
NOPRO
SPSV: 0 ;IMPORTANT TO SPECPDL BINDINGS
.SEE $IWAIT
;;; **** THERE MUST BE NO MORE USES OF THE MACRO SFX BEYOND HERE ****
EXPUNGE SFX SFSTO
;INTFLG NOQUIT UNREAL ERRSVD IMASK LFAKP LFAKFXP FAKP FAKFXP MONL6P KA10P UPIINT CCOCW1 CCOCW2 TENEXP INTPC1 INTPC2 INTPC3 PDLSVT SUPSAV LV2SVT LV2SVF LV2ST2 LV3SVT LV3SVF LV3ST2 DSMSAV CINTAB CINTSZ
SUBTTL INTERRUPT FLAGS AND VARIABLES
;;; INTFLG INDICATES WHETHER IN INTERRUPT IS PENDING:
;;; 0 => NO INTERRUPT
;;; -1 => USER INTERRUPT PENDING (STACKED IN INTAR)
;;; -2 => ↑X QUIT PENDING, DON'T RESET TTY
;;; -3 => ↑G QUIT PENDING, DON'T RESET TTY
;;; -6 => ↑X QUIT PENDING, DO RESET TTY
;;; -7 => ↑G QUIT PENDING, DO RESET TTY
INTFLG: 0
;;; MAY NOT ↑G/↑X QUIT OR ALLOW USER INTERRUPTS IF NOQUIT NON-ZERO
;;; NON-ZERO IN LH MEANS GC IN PROGRESS; IMPLIES
;;; PDL POINTERS AND NIL MAY BE CLOBBERED
;;; NON-ZERO ONLY IN RH MEANS PDL POINTERS AND NIL ARE OK
NOQUIT: 0
;;; MAY NOT ALLOW "REAL TIME" INTERRUPTS (CLOCK AND TTY) WHEN
;;; UNREAL IS NON-ZERO. MUNGED BY THE FUNCTION NOINTERRUPT.
;;; 0 => ALL INTERRUPTS OKAY
;;; -1 => NO INTERRUPTS OKAY
;;; 'TTY => ALARMCLOCK OKAY, TTY NOT OKAY
UNREAL: 0
ERRSVD: 0 .SEE ERRBAD
;;; INTERRUPT MASK IS ALWAYS INITIALIZED FROM THIS WORD.
;;; FOR ITS, THIS IS THE .MASK (AND .MSK2) WORDS.
;;; FOR TOPS10 AND CMU, THIS IS THE APRENB WORD.
;;; FOR D20, THIS IS THE CHANNEL ENABLE WORD
;;; DEPOSITING DBGMSK INTO IT BEFORE STARTUP CAN AID DEBUGGING.
;;; FOR ITS AND D20, IMPURE LISPS WILL HAVE DEBUG MASKS IN THESE
;;; LOCATIONS; THE PURIFY ROUTINE INSTALLS THE STANDARD MASKS.
.SEE PURIFY
.SEE DBGMSK
IFN <D10+D20>, OIMASK: 0 ;HOLDS OLD INT MASK WHEN INTS ARE DISABLED
SA% INTMSK:
IMASK: STDMSK ;INTERRUPT MASK WORD
IT$ IMASK2: STDMS2 ;ITS HAS TWO INTERRUPT MASKS
LFAKP==5 ;MUST BE LONG ENOUGH FOR USES BY
LFAKFXP==6 ; PDLOV, ERINIT, AND PURIFY
FAKP: BLOCK LFAKP ;FAKE REGPDL, FOR USE BY PDLOV AND ERINIT
FAKFXP: BLOCK LFAKFXP ;FAKE FIXPDL, FOR USE BY PDLOV AND ERINIT
IT$ VALFIX: 0 ;-1 --> VALRET 'STRING' IS REALLY A FIXNUM
IT$ .SEE VALSTR
IFN D10*<1-SAIL>,[
MONL6P: 0 ;6-LEVEL MONITOR OR BETTERP?
KA10P: 0 ;KA PROCESSOR (AS OPPOSED TO KL OR KI)
] ;END OF D10*<1-SAIL>
;;; IF NON-ZERO, THIS CONTAINS THE ADDRESS OF A USER-SUPPLIED
;;; INTERRUPT PROCESSOR. THE LISP SYSTEM INTERRUPT HANDLER
;;; WILL GIVE IT ANY INTERRUPT LISP DOESN'T PROCESS ITSELF. SEE INT0.
UPIINT: 0
IFN D20,[
;;; TOPS-20 INTERRUPT VARIABLES
;;; FLAGS SETUP BY ALLOC AND SUSPEND
CCOCW1: CCOC1 ;This words may be "remodeled" at allocation time, and at
CCOCW2: CCOC2 ; start-up from suspension, to account for 10X/20X differences
TENEXP: 0 ;Also set up as above
;;; BLOCK OF THREE LOCATIONS IN WHICH THE PC IS STORED ON AN INTERRUPT.
;;; ONE LOCATION FOR EACH OF TOPS-20'S THREE LEVELS
INTPC1: 0
INTPC2: 0
INTPC3: 0
;;; TEMPORARY LOCATIONS USED BY INTERRUPT HANDLERS
PDLSVT: 0 ;USED BY $PDLOV TO SAVE AC T WHILE MUNGING THE INTPDL
SUPSAV: 0 ;USED BY INTSUP
LV2SVT: 0 ;LEVEL 2 PARAMETERS: SAVE T
LV2SVF: 0 ; SAVE F
LV2ST2: 0 ; SECOND SAVE T
LV3SVT: 0 ;LEVEL 3 PARAMETERS: SAVE T
LV3SVF: 0 ; SAVE F
LV3ST2: 0 ; SECOND SAVE T
DSMSAV: . ;POINTER INTO SMALL STACK USED BY DSMINT
BLOCK 10 ;TO BE SAFE, BUT 4 SHOULD BE MAXIMUM DEPTH
IT% CN.ZX: 0 ;WHERE TO EXIT AFTER ↑Z
;;; AS TTY INTERRUPT CHANNEL MUST BE DYNAMICALLY ALLOCATED, AND THERE ARE
;;; FEWER CHANNELS THAN THE TOTAL POSSIBLE NUMBER OF INTERRUPT CHARACTERS,
;;; A TABLE IS USED TO STORE THE INFORMATION. THE TABLE IS 18. WORDS LONG.
;;; A ZERO ENTRY IS UNUSED, NONZERO HAS INTERRUPT CHARACTER. IF THE TABLE
;;; ENTRY IS NEGATIVE, THEN THE CHANNEL IS ASSIGNED FOR SOME OTHER USE.
;CHANNEL ASSIGNMENTS FOR NON-STANDARD(?) INTERRUPTS
CINTAB:
TICMAP .TIC!CODE
REPEAT 18.-<.-CINTAB>, 0 ;INITIALLY UNUSED
CINTSZ==.-CINTAB
] ;END IFN D20
;STTYW1 STTYW2 STTYL1 STTYL2 STTYA1 STTYA2 CCOC1 CCOC2 XACTW XACTL STDTIW SACTW1 SACTW2 SACTW3 SACTW4 SACTL1 SACTL2 SACTL3 SACTL4
SUBTTL DEFINITIONS OF TTY STATUS WORDS
IFN ITS,[
;;; INITIAL TTY STATUS IS AS FOLLOWS:
;;; ACTIVATION CHARS:
;;; ↑@-↑L, ↑N-↑Z, ↑\-↑←, SPACE, < > ( ) { } RUBOUT CR
;;; LBRACKET RBRACKET
;;; INTERRUPT CHARS:
;;; ↑@-↑H, ↑K, ↑L, ↑N-↑Z, ↑\-↑←, SPACE
;;; ↑H AND SPACE DO NOT INTERRUPT
;;; SPACE AND BACKSPACE OUTPUT IN IMAGE MODE, ALL OTHERS IN ASCII.
;;; ALL CHARS ECHO IN PI MODE (ECHO WHEN TYPED), EXCEPT RUBOUT DOESN'T ECHO.
;;;
;;; RECALL THAT THE TWELVE CHARACTER GROUPS ARE:
;;; ↑@ ↑A-↑F ↑K-↑L ↑N-↑R ↑T-↑Z ↑RBRACKET ↑\ ↑↑ ↑←
;;; A-Z (UPPER CASE), a-z (LOWER CASE)
;;; 0-9
;;; ! " # $ % & ' , . : ; ? @ \ ` | }
;;; * + - / = ↑ ←
;;; < > ( ) { } LBRACKET RBRACKET
;;; ↑G ↑S
;;; ↑J ↑I
;;; ALTMODE
;;; ↑M
;;; RUBOUT
;;; SPACE ↑H
.SEE %TG
STTYW1==:232020,,202022 ;STATUS WORDS FOR NORMAL MODE
STTYW2==:232220,,220232
STTYL1==:232020,,202020 ;STATUS WORDS FOR LINE MODE
STTYL2==:212020,,220222
STTYA1==:022222,,222222 ;STATUS WORDS FOR ALLOC
STTYA2==:320222,,020222
] ;END OF IFN ITS
IFN D20,[
;;; Control-Character-Output-Control - two bits for each control character
;;; 0 - ignore,
;;; 1 - print ↑X,
;;; 2 - output unmodified,
;;; 3 - simulate format action
RADIX 4
CCOC1==:111111123321231111
CCOC2==:111111111311110000
RADIX 8
; SEE CCOCW1 AND CCOCW1
;;; Four classes of wake-up control
XACTW==:TT%WKF+TT%WKN+TT%WKP+TT%WKA
XACTL==:TT%WKF
STDTIW==0 ;STANDARD TERMINAL INTERRUPT WORD - not really used!
TICMAP {STDTIW==STDTIW+<1←<35-.TIC!CODE>>}
] ;END OF IFN D20
IFN SAIL,[
SACTW1==:777777777370
SACTW2==:030000005000
SACTW3==:000000240000
SACTW4==:000005200000
SACTL1==:775177577370
SACTL2==:000000000000
SACTL3==:000000000000
SACTL4==:000000200000
] ;END OF IFN SAIL
;UISTAK GCRSR PDLSTH PDLSTA PDLSTB PDLSTC
SUBTTL ENTRIES TO VARIOUS ROUTINES CALLED BY JSR
UISTAK: 0 ;STACK UP (ACTUALLY, QUEUE) A USER INTTERRUPT
JRST UISTK1
GCRSR: 0 ;GC RESTORE. CLEANS UP JUST BEFORE AN
JRST GCRSR0 ; ABNORMAL EXIT (GCEND IS NORMAL EXIT).
IFN PAGING,[
PDLSTH: 0 ;"PDL ST HACK". GETS A NEW PAGE FOR A PDL,
JRST PDLST0 ; AND UPDATES ST AND GCST APPROPRIATELY.
IFN D20,[
PDLSTA: 0 ;TEMPS FOR SAVING ACS
PDLSTB: 0
PDLSTC: 0
] ;END OF IFN D20
] ;END OF IFN PAGING
;CHNTB TMPC DPAGEL DLINEL LJOBTB JOBTB
SUBTTL NEWIO I/O CHANNEL ALLOCATION TABLE
;;; ENTRIES:
;;; 4.9 => CHANNEL IS LOCKED FOR A PARTICULAR PURPOSE
;;; 1.1-2.9 => ADDRESS OF FILE ARRAY SAR
;;; IF AN ENTRY IS NON-ZERO BUT ITS FILE ARRAY SAR'S
;;; TTS.CL BIT IS SET, THE CHANNEL MAY BE DE-ALLOCATED.
;;; THIS ORDINARILY HAPPENS ONLY ON A QUIT OUT OF $OPEN.
;;; CHANNEL 0 (TMPC) IS PERMANENTLY LOCKED FOR USE OF THE ERR
;;; DEVICE, FOR UPROBE, ETC. NOTE THAT ITS PUTS .OPEN
;;; AND .CALL FAILURE CODES ON CHANNEL 0 ARBITRARILY.
IFN ITS+D10, LCHNTB==:20 ;NUMBER FIXED BY OPERATING SYSTEM
IFN D20, MAYBE LCHNTB==:40 ;THIS NUMBER IS BASICALLY ARBITRARY
CHNTB:
OFFSET -.
TMPC:: 400000,,NIL ;FIXED TEMPORARY CHANNEL
IFGE LCHNTB-., BLOCK LCHNTB-.
.ELSE WARN [TOO MANY FIXED I/O CHANNELS]
OFFSET 0
;;; DEC-10 I/O BUFFER HEADERS (MUST REMAIN FIXED IN CORE)
;;; THEY ARE NAMED BFHD0, BFHD1, ..., BFHD17.
IFN D10, REPEAT LCHNTB, CONC BFHD,\.RPCNT,: BLOCK 3
DPAGEL: 60. ;INITIAL DEFAULT PAGEL
DLINEL: 70. ;INITIAL DEFAULT LINEL
IFN JOBQIO,[
LJOBTB==10 ;EIGHT INFERIOR PROCEDURES
JOBTB: BLOCK LJOBTB
] ;END OF IFN JOBQIO
;TTYIF1 TTYIF2 FI.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 F.RDEV F.DEV
SUBTTL INITIAL TTY INPUT FILE ARRAY
-F.GC,,TTYIF2 ;GC AOBJN POINTER
TTYIF1: JSP TT,1DIMS
TTYIFA ;POINTER BACK TO SAR
0 ;ILLEGAL FOR USER TO ACCESS - DIMENSION IS ZERO
TTYIF2:
OFFSET -.
FI.EOF:: NIL ;EOF FUNCTION (??)
FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS
FI.BBF:: NIL ;BUFFERED BACK FORMS
TI.BFN:: QTTYBUF ;PRE-SCAN FUNCTION
FT.CNS:: TTYOFA ;ASSOCIATED TTY OUTPUT FILE
REPEAT 3, 0 ;UNUSED SLOTS
F.MODE:: SA% FBT.CM,,2 ;MODE (ASCII TTY IN SINGLE)
SA$ FBT.CM\FBT.LN,,2
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
20$ F.JFN:: .PRIIN ;JFN (FOR D20 ONLY)
20% 0
F.FLEN:: -1 ;WE EXPECT RANDOM ACCESS TO BE ILLEGAL
F.FPOS:: 0 ;FILE POSITION
REPEAT 3, 0 ;UNUSED SLOTS
IFN ITS+D10,[
F.DEV:: SIXBIT \TTY\ ;DEVICE
IT$ F.SNM:: 0 ;SNAME (FILLED IN)
10$ F.PPN:: 0 ;PPN (FILLED IN)
F.FN1::
IT$ SIXBIT \.LISP.\ ;FILE NAME 1
10$ SIXBIT \LISP\
F.FN2::
IT$ SIXBIT \INPUT\ ;FILE NAME 2
10$ SIXBIT \IN\
F.RDEV:: BLOCK 4 ;TRUE FILE NAMES
] ;END OF IFN ITS+D10
IFN D20,[
F.DEV:: ASCII \TTY\
] ;END OF IFN D20
LOC TTYIF2+LOPOFA
IFN ITS+D20+SAIL,[
; TI.ST1::
IT$ STTYW1 ;TTY STATUS WORDS
20$ CCOC1
SA$ SACTW1
; TI.ST2::
IT$ STTYW2
20$ CCOC2
SA$ SACTW2
; TI.ST3::
SA$ SACTW3
20$ XACTW
10$ 0
; TI.ST4::
SA$ SACTW4
20$ STDTIW
IT$ 0
] ;END OF IFN ITS+D20+SAIL
.ELSE BLOCK 4
; 0 .SEE ATO.LC
; AT.CHS:: 0 ;CHARPOS
; AT.LNN:: 0 ;LINENUM
; AT.PGN:: 0 ;PAGENUM
; BLOCK 10
; LONBFA:: BLOCK 10
LOC TTYIF2+FB.BUF
; FB.BUF:: ;INTERRUPT FUNCTIONS
IFE SAIL,[
NIL,,IN0+↑A ;↑@ ↑A "SIGNAL" ON
IT% QCN.BB,,NIL ;↑B ↑B-BREAK ↑C
IT$ QCN.BB,,IN0+↑C ;↑B ↑B-BREAK ↑C GC STAT OFF
IN0+↑D,,NIL ;↑D GC STAT ON ↑E
NIL,,IN0+↑G ;↑F ↑G HARD QUIT
REPEAT 3, NIL,,NIL ;↑H-↑M (FORMAT EFFECTORS)
NIL,,NIL ;↑N ↑O
NIL,,NIL ;↑P ↑Q
IT% IN0+↑R,,NIL ;↑R UWRITE ON? ↑S
IT$ IN0+↑R,,IN0+↑W ;↑R UWRITE ON? ↑S ↑W INT, ↑V MACRO
IN0+↑T,,NIL ;↑T UWRITE OFF? ↑U
IN0+↑V,,IN0+↑W ;↑V TTY ON ↑W TTY OFF
IN0+↑X,,NIL ;↑X SOFT QUIT ↑Y
IN0+↑Z,,NIL ;↑Z GO TO DDT ≠ <ALTMODE>
NIL,,NIL ;↑\ CONTROL RIGHT-BRACKET
NIL,,NIL ;↑↑ ↑←
REPEAT <NASCII/2>-<.-FB.BUF>, NIL,,NIL ;ALL OTHERS INITIALLY UNUSED
] ;END IFE SAIL
IFN SAIL,[
REPEAT 100, NIL,,NIL ;ALPHABETIC (ASCII 0 THROUGH ASCII 177)
REPEAT 40, NIL,,NIL ;LOW CONTROL ↑<NULL> UP TO ↑@ (200-277)
NIL,,IN0+↑A ; ↑A
QCN.BB,,IN0+↑C ;↑B ↑C
IN0+↑D,,NIL ;↑D
NIL,,IN0+↑G ;↑F ↑G
REPEAT 3, NIL,,NIL
NIL,,NIL ;↑N ↑O
NIL,,NIL ;↑P ↑Q
IN0+↑R,,IN0+↑W ;↑R ↑S
IN0+↑T,,NIL ;↑T
IN0+↑V,,IN0+↑W ;↑V ↑W
IN0+↑X,,NIL ;↑X ↑Y
IN0+↑Z,,NIL ;↑Z
REPEAT 5, NIL,,NIL
NIL,,IN0+↑G ;LOWERCASE ↑G
REPEAT 11, NIL,,NIL
IN0+↑Z,,NIL
REPEAT <NASCII/2>-<.-FB.BUF>, NIL,,NIL
] ;END IFN SAIL
OFFSET 0
;TTYOF1 TTYOF2 FO.EOP FT.CNS F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.FN1 F.FN2 F.RDEV F.DEV FO.LNL FO.PGL FO.RPL
SUBTTL INITIAL TTY OUTPUT FILE ARRAY
-F.GC,,TTYOF2 ;GC AOBJN POINTER
TTYOF1: JSP TT,1DIMS
TTYOFA ;POINTER BACK TO SAR
0 ;USER MAY NOT ACCESS, SO SAY DIMENSION IS ZERO
TTYOF2:
OFFSET -.
FO.EOP:: QTTYMOR ;END OF PAGE FUNCTION
REPEAT 3, 0
FT.CNS:: TTYIFA ;STATUS TTYCONS
REPEAT 3, 0
F.MODE:: FBT.CM,,3 ;MODE (ASCII TTY OUT SINGLE)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
20$ F.JFN:: .PRIOU ;JFN
20% 0
F.FLEN:: -1 ;NOT RANDOMLY ACCESSIBLE
F.FPOS:: 0 ;FILE POSITION
REPEAT 3, 0
IFN ITS+D10,[
F.DEV:: SIXBIT \TTY\ ;DEVICE
IT$ F.SNM:: 0 ;SNAME (FILLED IN)
10$ F.PPN:: 0 ;PPN (FILLED IN)
F.FN1::
IT$ SIXBIT \.LISP.\ ;FILE NAME 1
10$ SIXBIT \LISP\
F.FN2::
IT$ SIXBIT \OUTPUT\ ;FILE NAME 2
10$ SIXBIT \OUT\
F.RDEV:: BLOCK 4 ;TRUE FILE NAMES
] ;END OF IFN ITS+D10
IFN D20,[
F.DEV:: ASCII \TTY\
] ;END OF IFN D20
LOC TTYOF2+LOPOFA
BLOCK 4
0 ;ATO.LC LINEFEED/SLASH FLAG
0 ;AT.CHS CHARPOS
0 ;AT.LNN LINENUM
0 ;AT.PGN PAGENUM
FO.LNL:: 71. ;LINEL
FO.PGL:: 200000,, ;PAGEL
FO.RPL:: 24. ;"REAL" PAGEL
OFFSET 0
BLOCK <LOPOFA+LONBFA>-<.-TTYOF2>
;SWS ERRTN CATRTN EOFRTN PA4 INHIBIT ERRSW BFPRDP CATID CATSPC CATLIS CATUWP CATCAB CATALL CATCOM LEP1 UIRTN RSXTB PNMK1 GCD.A UNBND3 SIXMK2 SAVMAR GCD.B AUNBD EXP.S ATAN.S UNMTMP FPTEM IFLT9 EQLP GCD.C ATAN.X GWDCNT GCD.D ATAN.Y GWDORG GWDRG1
SUBTTL SUPER-WRITABLE STUFF - MUST BE SAVED UPON USER INTERRUPT
;;; DONT ALLOW USER INTERRUPTS WHILE:
;;; (1) NOQUIT IS NON-ZERO - THIS PROTECTS GC,
;;; RETSP, SUBLIS, AND OTHERS.
;;; (2) INHIBIT IS NON-ZERO - THIS PROTECTS
;;; MANY AREAS OF SEMI-CRITICAL CODE.
;;; (CF. LOCKI AND UNLOCKI MACROS)
;;; (3) UNREAL IS NON-ZERO (DEPENDS ONEXACT VALUE)
;;; - THIS IS FOR THE NOINTERRUPT FUNCTION
SWS::
;;; THE FOLLOWING STUFF IS SAVED WHEN AN "ERRSET FRAME" IS CREATED.
;;; NOT ONLY ERRSET, BUT ALSO CATCH AND READ NEED TO DO THIS.
;;; INTERPRETED PROGS CREATE A SORT OF HALF-ASSED FRAME.
;;; BEWARE! THE COMPILER DEPENDS ON KNOWING THE LENGTH OF
;;; THE ERRSET FRAME AS A CONSTANT PARAMETER.
ERRTN: 0 ;PDL RESTORATION FOR ERRSET
CATRTN: 0 ;PDL RESTORATION FOR CATCH OF A THROW
EOFRTN: 0 ;PDL RESTORATION ON E-O-F TRAPOUT
PA4: 0 ;PDL RESTORATION ON GO OR RETURN
INHIBIT: 0 ;NON-ZERO => INHIBIT (DELAY) USER INTERRUPTS
ERRSW: -1 ;0 MEANS NO PRINT ON ERROR DURING ERRSET
BFPRDP: 0 ;LH: FUNCTION WHICH WANTS TTY PRE-SCAN
; (READ, READLINE)
; TYI FOR ACTIVATION AND CURSORPOS
; CLEVERNESS, BUT NO PRE-SCAN
; NIL FOR NO CLEVERNESS AT ALL
;RH: -1 IF WITHIN READ
CATID: NIL ;RH: CATCH IDENTIFICATION TAG
;LH: FLAGS INDICATING SUBTYPE OF FRAME
CATSPC==400000 ; SPECIAL PROCESSING NEED BE DONE (OTHER BITS HAVE
; MEANING)
CATLIS==200000 ; C(RH) IS POINTER TO A LIST OF CATCH TAGS
CATUWP==100000 ; UNWIND-PROTECT, C(RH) IS FUNCTION
CATCAB==040000 ; CATCH-BARRIER: RH POINTER TO (CONS FUN CATCH-TAGS)
CATALL==020000 ; CATCH-ALL: RH IS FUNCTION OF TWO ARGS
CATCOM==010000 ; FROM COMPILED CODE, DO CALLF, NOT IPROGN
LEP1==.-ERRTN ;***** LENGTH OF SOME OF ERRSET PUSH
.SEE ERSTP
UIRTN: 0 ;NON-ZERO => PDL LOC OF MOST RECENT USER INT FRAME
.SEE UINT0
RSXTB: (A) ;POINTER TO READ SYNTAX TABLE, INDEXED BY A
PNMK1: 0 .SEE PDLNMK ;SAVE TT
GCD.A: .SEE GCDBB
UNBND3: .SEE UNBIND ;SAVE TT
SIXMK2: 0 .SEE SIXMAK
SAVMAR: .SEE SUSP14 ;NEEDN'T BE IN SWS, BUT WHO CARES?
GCD.B: .SEE GCDBB
AUNBD: .SEE AUNBIND ;SAVES D FOR AUNBIND
EXP.S: .SEE EXP ;REMEMBERS SIGN OF ARG
ATAN.S: .SEE ATAN ;SAVES SIGNS OF ARGS <X,,Y>
UNMTMP: ;UNAME TEMP
FPTEM: ;PSYM WANTS THIS TO BE SAME AS PCNT!!!
IFLT9: .SEE IFLOAT ;D SAVED HERE
EQLP: 0 ;PDL POINTER UPON ENTRY TO EQUAL
.SEE EQUAL
GCD.C: .SEE GCDBB
ATAN.X: .SEE ATAN ;TEMPORARY X VALUE
GWDCNT: 0
GCD.D: .SEE GCDBB
ATAN.Y: .SEE ATAN ;TEMPORARY Y VALUE
GWDORG: 0 ;ORIGIN OF LAPPIFICATION - GWDRG1 IS GWDORG-1
GWDRG1: 0
;EXPL5 GCD.UH BKTRP EV0B FLAT1 MEMV UAPOS GCD.VH LPNF AUNBR DLTC RINF APFNG1 TABLU1 AUNBF MNMX0 GRESS0 GRESS0 CFAIL CSUCE BACTYF BOOLI TOPAST PLUS0 PLUS3 PLUS6 PLUS8 RM4 SWNACK RDBKBF RDBKC RDNSV RDDSV RDIBS RDINCH CORBP MKNCH
EXPL5: 0 ;TEMP FOR EXPLODE
GCD.UH: .SEE GCDBB
BKTRP: .SEE BAKTRACE
EV0B: .SEE EVAL
FLAT1: .SEE FLATSIZE
MEMV: 0 .SEE MEMBER
UAPOS: ;-1=> UWRITE, >=0 => UAPPEND .ACCESS POS
GCD.VH: .SEE GCDBB
LPNF: ;-1 MEANS NOT A LONG PNAME (FITS IN PNBUF)
.SEE RINTERN
AUNBR: 0 ;SAVES R FOR AUNBIND
DLTC: 0 ;# OF TIMES DELETE/DELQ SHOULD REMOVE ITEM
.SEE DELQ
RINF:
APFNG1:
TABLU1: 0
AUNBF: ;SAVES F FOR AUNBIND
IFE BIGNUM,[
MNMX0: ;"MIN" INSTRUCTION
GRESS0: 0 ;"GREATERP" INSTRUCTION
] ;END OF IFE BIGNUM
IFN BIGNUM,[
GRESS0: 0 ;"MIN" AND"GREATERP" INSTRUCTION
CFAIL: JRST . ;TRANSFER ON FAILURE
CSUCE: JRST . ;TRANSFER ON SUCCEED
] ;END OF IFN BIGNUM
IT$ IOST: .STATUS 00,A
IFN ITS, SYSCL8:
BACTYF: 0 ;ZERO ON FIRST LOOP THROUGH BACTRACE.
BOOLI: SETZB D,TT ;BOOLEAN INSTRUCTION FOR BOOLE
TOPAST: -1 ;IF -1 THEN TOP-LEVEL ASTERISK NOT PRINTED IF VINFILE
; IS INIIFA
IFN USELESS, PRINLV: ;<CURRENT PRINT LEVEL>-1
PLUS0: 0 ;TYPE - QFIXNUM OR QFLONUM
IFE BIGNUM,[
PLUS3: ADD D,TT
PLUS6: FAD D,TT ;FLOAT-POINT INSTRUCTION FOR ARITH GENERATOR
] ;END OF IFE BIGNUM
IFN USELESS, ABBRSW: ;KIND OF STUFF DESIRED FROM PRINT0:
; - => ONLY ABBREV STUFF
; 0 => ONLY NON-ABBREV STUFF
; + => BOTH (DISTINGUISHED BY TYOSW)
PLUS8: 0 ;<N,,N> WHERE THERE ARE N ARGS
RM4: 0
IFN USELESS, PRPRCT: ;PRINT'S PARENS COUNTS (LEFT,,RIGHT)
SWNACK: 0 ;USED FOR WNA CHECKING IN STATUS
JRST STAT1
IFN USELESS, TYOSW: 0 ;NORMALLY ZERO - TELLS TYO TYPE OF CHAR
; + => CHAR IS FOR FILES ONLY
; - => CHAR IS FOR TTY ONLY
; 0 => CHAR IS FOR BOTH FILES AND TTY
RDBKBF: 0 ;OCCASIONALLY, A BREAK CHARA HAS TO BE BUFFERED BACK
RDBKC: 0 ;SAVED BREAK CHARACTER, ON EXIT FROM RDCHAR
RDNSV: 0 ;SAVED NUMBER (BEFORE DECIMAL-OR-NOT IS DECIDED)
RDDSV: 0 ;SAVED VALUE OF # OF DIGITS TO RIGHT OF DECIMAL POINT
RDIBS: 0 ;NUMERIC IBASE DURING READING
IFN USELESS, RDROMP: 0 ;ROMANP - ARE ROMAN NUMERALS OK?
RDINCH: 0 ;SOURCE OF CHARACTERS FOR READ
CORBP: 0 ;BYTE-POINTER FOR READ-SOURCE WHEN SOURCE IS BLOCK OF
;ASCII OR SIXBIT STUFF IN CORE
MKNCH: 0 ;INSTRUCTIION FOR MAKNAM TO GET NEXT BYTE
;PNBP PNBUF JCLBF ATMBF REMFL VETBL0 DVS1 DVS2 DVSL DD1 DD2 DD3 DDL NORMF QHAT BNMSV FACF FACD AGDBT YAGDBT TSAVE DSAVE RSAVE FSAVE NRD10FL LJCLBF UUOH ERROR ERBDF UUOFN UUTSV UUTTSV UURSV UUALT9 UUPSV UUOBKG LUUSV LSWS
;;; THE PNAME BUFFER IS USED FOR VARIOUS AND SUNDRY PURPOSES.
;;; THE PRIMARY PURPOSE IS ACCUMULATING PRINT NAMES OF ATOMS.
.SEE RINTERN
;;; IT IS ALSO USED FOR VALRET AND SUSPEND STRINGS,
.SEE VALRET
.SEE SUSPEND
;;; JCL, NAMESTRINGS OF FILES (ESPECIALLY FOR D20 GTJFN JSYS),
.SEE 6BTNS
;;; ERROR MESSAGE STRING PROCESSING,
.SEE ERRIOJ
;;; AND SO ON. FOR SOME PURPOSES THIS BUFFER OVERLAPS THE BIGNUM TEMPS.
20% MAYBE LPNBUF==:10
20$ MAYBE LPNBUF==:50
PNBP: 440700,,PNBUF ;BYTE POINTER FOR PNAME BUFFER
PNBUF: BLOCK LPNBUF
0 ;EXTRA WORD USED TO GUARANTEE THAT A STRING CAN BE MADE ASCIZ
JCLBF==:PNBUF+1 ;SINCE STATUS JCL MAY CALL INTERN ON A SCO
ATMBF==:PNBUF+1 ;DITTO INTERACTION BETWEEN PRINTA AND EXPLODE
IFN BIGNUM,[
REMFL: 0 ;REMAINDER FLAG
VETBL0: 0 ;DIVISION STUFF
DVS1: 0
DVS2: 0
DVSL: 0
DD1: 0
DD2: 0
DD3: 0
DDL: 0
NORMF: 0
QHAT: 0
BNMSV: 0
FACF: 0
FACD: 0
AGDBT: 0
YAGDBT: 0
TSAVE: 0
DSAVE: 0
RSAVE: 0
FSAVE: 0
NRD10FL: 0 ;NOT READING IN BASE 10. FLAG
] ;END OF IFN BIGNUM
IFG JCLBF+24-., BLOCK JCLBF+24-. ;MUST HAVE AT LEAST 24 WDS
LJCLBF==:.-JCLBF
UUOH: ;KEEP THIS UUO STUFF CONTIGIOUS SO THAT GC CAN SAVE IT.
ERROR: 0
JRST UUOH0
ERBDF: ;SOME RANDOM TEMP FOR UUO HANDLER
UUOFN: 0 ;POINTER TO FUNCTION DURING THE UUOH1 LOOP
UUTSV: 0
UUTTSV: 0
UURSV: 0
UUALT9: .SEE UUALT ;DOESN'T CONFLICT WITH UUPSV
UUPSV: 0
UUOBKG: 0 ;IF IN *RSET MODE, PUT STUFF ON PDL
LUUSV==:.-UUOH ;STUFF THAT NEEDS SAVING FOR THE UUO HANDLER
LSWS==:.-SWS ;TOTAL LENGTH OF SUPER-WRITABLE STUFF
JRST UUBKG1
;;; ******** STUFF SAVED UPON USER INTERRUPT ENDS HERE ********
;FFS FFX FFL FFY FFA NFF FFY2 NPFFS NPFFX NPFFL NPFFY2 EPFFS EPFFX EPFFL EPFFY2 EFVCS NFVCP FFVC ETVCFLSP
SUBTTL FREE STORAGE LISTS, AND GC AND ALLOC PARAMETERS
;;; ********** FREE STORAGE LISTS **********
;;; THESE ARE USED BY THE VARIOUS CONSERS TO ALLOCATE CELLS OF
;;; THE VARIOUS FREE STORAGE SPACES. NEVER PUT ONE OF THESE IN
;;; A MARKABLE AC (EXCEPT WITHIN A PROPERLY PROTECTED CONSER)!
;;; CAUTION! MUST PRESERVE RELATIVE ORDERING OF
;;; FFS,FFX,FFL,FFD,FFC,FFZ,FFB,FFY,FFH,FFA,FFY2
.SEE GC ;GARBAGE COLLECTOR
FFS: 0 ;LIST FREE STORAGE LIST
FFX: 0 ;FIXNUMS (AND PNAME AND BIGNUM WORDS)
FFL: 0 ;FLONUM WORDS LIST
DB$ FFD: SETZ ;DOUBLE-PRECISION FLONUMS
CX$ FFC: SETZ ;COMPLEX NUMBERS
DX$ FFZ: SETZ ;DOUBLE-PRECISION COMPLEX (DUPLEX)
BG$ FFB: 0 ;BIGNUM HEADERS
FFY: 0 ;SYMBOL (PNAME-TYPE ATOM) HEADERS
HN$ FFH: REPEAT HNKLOG+1, SETZ ;HUNKS
FFA: 0 ;SARS (ARRAY POINTERS)
NFF==:.-FFS ;NUMBER OF FF FROBS
FFY2: SY2ALC ;SYMBOL BLOCKS (EXPLICIT RETURN USED)
;;; SIGN BIT IN FF- MEANS EXEMPT FROM 40-WORD MINIMUM RECLAIMED.
.SEE GCSWH1
.SEE AGC1Q
.SEE GCE0C5
.SEE GCE0C9
.SEE HUNK
;;; PURE FREE STORAGE COUNTERS (NON-POSITIVE, RELATIVE TO EPFF- BELOW)
;;; MUST PRESERVE RELATIVE ORDERING THROUGH NPFFY2
NPFFS: 0 ;LIST
NPFFX: 0 ;FIXNUM
NPFFL: 0 ;FLONUM
DB$ NPFFD: 0 ;DOUBLE
CX$ NPFFC: 0 ;COMPLEX
DX$ NPFFZ: 0 ;DUPLEX
BG$ NPFFB: 0 ;BIGNUM
0 ;NO PURE SYMBOLS
HN$ NPFFH: REPEAT HNKLOG+1, 0 ;HUNKS
0 ;NO PURE SARS
IFN .-NPFFS-NFF, WARN [NPFF- TABLE WRONG LENGTH]
NPFFY2: 0 ;SYMBOL BLOCKS
;;; ADDRESS OF WORD ABOVE CURRENT PURE SEGMENT FOR EACH SPACE
;;; MUST PRESERVE RELATIVE ORDERING THROUGH EPFFY2
EPFFS: 0 ;LIST
EPFFX: 0 ;FIXNUM
EPFFL: 0 ;FLONUM
DB$ EPFFD: 0 ;DOUBLE
CX$ EPFFC: 0 ;COMPLEX
DX$ EPFFZ: 0 ;DUPLEX
BG$ EPFFB: 0 ;BIGNUM
0 ;NO PURE SYMBOLS
HN$ EPFFH: REPEAT HNKLOG+1, 0 ;HUNKS
0 ;NO PURE SARS
IFN .-EPFFS-NFF, WARN [EPFF- TABLE WRONG LENGTH]
EPFFY2: 0 ;SYMBOL BLOCKS
EFVCS: BVCSG+NVCSG*SEGSIZ ;END OF CURRENT VC REGION (EFVCS+NFVCS=LAST USED VC)
NFVCP: NXVCSG/SGS%PG ;NUMBER OF EXTRA VC PAGES
FFVC: BFVCS ;VALUE CELL FREELIST (EXPLICIT RETURN USED)
ETVCFLSP: 0 .SEE GCMARK ;EVER-TOOK-VALUE-CELL-FROM-LIST-SPACE-P
;GCMKL PROLIS MFFS MFFX MFFL MFFY MFFA NFFS NFFX NFFL NFFY NFFA GCWHO GCWHO1 GCWHO2 GCWHO3 GCACSAV GCNASV GCP GCFLP GCFXP GCSP PANICP GCMRKV GCTIM GCTM1 GCUUSV IRMVF GCRMV ARPGCT
;;; GCMKL IS ARRANGED LIKE A PROPERTY LIST: THE "PROPERTY NAMES"
;;; ARE SARS, IN DECREASING ORDER OF POSITION IN ARRAY SPACE,
;;; AND THE "PROPERTY VALUES" ARE FIXNUMS DENOTING THE LENGTHS
;;; OF THE ARRAYS. USED BY GC, RETSP, GRELAR, *ARRAY, AND OTHERS
;;; TO KEEP TRACK OF ARRAYS. NOTE: THE INITIAL OBARRAY AND
;;; READTABLE ARE NOT IN GCMKL SINCE THEY ARE NOT IN BPS.
GCMKL: IGCMKL
;;; PROLIS IS AN ALIST USED TO PROTECT NON-ATOMIC READ-MACRO
;;; FUNCTIONS FROM BEING GC'ED. EACH ITEM ON THE
;;; ALIST IS OF THE FORM (FUN RDT . NUM) WHERE:
;;; FUN IS THE FUNCTION TO BE PROTECTED
;;; RDT IS THE SAR OF THE READTABLE CONCERNED
;;; NUM IS A LISP NUMBER (GUARANTEED NLISP INUM)
;;; <ASCII CHAR VALUE> FOR READ-MACRO FUNCTION
;;; PROLIS IS UPDATED BY SSGCPRO AND SSGCREL.
PROLIS: NIL
;;; VARIOUS RANDOM PARAMETERS FOR GARBAGE COLLECTOR.
;;; MUST PRESERVE RELATIVE ORDER WITHIN GROUPS.
;;; GCMIN PARAMETERS FOR EACH SPACE (FLONUM IFF LH NON-ZERO)
.SEE GCE0C0
MFFS: MINFFS ;LIST
MFFX: MINFFX ;FIXNUM
MFFL: MINFFL ;FLONUM
DB$ MFFD: MINFFD ;DOUBLE
CX$ MFFC: MINFFC ;COMPLEX
DX$ MFFZ: MINFFZ ;DUPLEX
BG$ MFFB: MINFFB ;BIGNUM
MFFY: MINFFY ;SYMBOL
HN$ MFFH: REPEAT HNKLOG+1, MINFFH ;HUNKS
MFFA: MINFFA ;SARS
IFN .-MFFS-NFF, WARN [MFF- TABLE WRONG LENGTH]
;;; LENGTH OF FREELISTS <BEFORE,,AFTER>
.SEE GCP4B
NFFS: 0 ;LIST
NFFX: 0 ;FIXNUM
NFFL: 0 ;FLONUM
DB$ NFFD: 0 ;DOUBLE
CX$ NFFC: 0 ;COMPLEX
DX$ NFFZ: 0 ;DUPLEX
BG$ NFFB: 0 ;BIGNUM
NFFY: 0 ;SYMBOL
HN$ NFFH: REPEAT HNKLOG+1, 0 ;HUNKS
NFFA: 0 ;SARS
IFN .-NFFS-NFF, WARN [NFF- TABLE WRONG LENGTH]
IFN USELESS*ITS,[
GCWHO: 0 ;VALUE OF (STATUS GCWHO)
;1.1 => DISPLAY MESSAGE DURING GC
;1.2 => CLOBBER .WHO2 WITH GC STATISTICS
GCWHO1: 0 ;SAVED VALUES OF WHO-LINE VARIABLES DURING GC
GCWHO2: 0
GCWHO3: 0
] ;IFN USELESS*ITS
GCACSAV: BLOCK NACS+1 ;MARKED ACS SAVED HERE
GCNASV: BLOCK 20-<NACS+1> ;UNMARKED ACS SAVED HERE
GCP=:GCACSAV+P
GCFLP=:GCACSAV+FLP
GCFXP=:GCACSAV+FXP ;TEST GCFXP FOR NON-ZERO TO DECIDE IF
GCSP=:GCACSAV+SP ; INSIDE GC (IMPLYING REAL PDL POINTERS ARE HERE)
PANICP: 0 ;-1 SAYS WE'RE CLOSE TO RUNNING OUT OF CELLS
GCMRKV: 0 ;NON-NIL MEANS MARK PHASE ONLY
GCTIM: 0 ;GC TIME
GCTM1: 0
GCUUSV: BLOCK LUUSV
IRMVF: 0 ;GCTWA REMOVAL OVERRIDE SWITCH
GCRMV: 0 ;WHETHER TO DO GCTWA REMOVAL
ARPGCT: 4 ;# OF PAGES TO GRAB FREELY FOR ARRAYS BEFORE GC
;ZFFS ZFFX ZFFL ZFFY ZFFA SFSSIZ SFXSIZ SFLSIZ SSYSIZ SSASIZ OFSSIZ OFXSIZ OFLSIZ OSYSIZ OSASIZ GFSSIZ GFXSIZ GFLSIZ GSYSIZ GSASIZ
;;; PARAMETERS RELEVANT TO MEMORY ALLOCATION.
;;; MUST PRESERVE RELATIVE ORDERING OF MOST OF THIS STUFF.
;USED BY GC TO HOLD EXACT CALCULATED INTEGRAL GCMINS
ZFFS: 0 ;LIST
ZFFX: 0 ;FIXNUM
ZFFL: 0 ;FLONUM
DB$ ZFFD: 0 ;DOUBLE
CX$ ZFFC: 0 ;COMPLEX
DX$ ZFFZ: 0 ;DUPLEX
BG$ ZFFB: 0 ;BIGNUM
ZFFY: 0 ;SYMBOL
HN$ ZFFH: REPEAT HNKLOG+1, 0 ;HUNK
ZFFA: 0 ;SARS
IFN .-ZFFS-NFF, WARN [ZFF- TABLE WRONG LENGTH]
.SEE SSPCSIZE ;SIZE OF EACH SWEEPABLE SPACE. USED TO CALCULATE PERCENTAGE RECLAIMED.
SFSSIZ: NIFSSG*SEGSIZ ;LIST
SFXSIZ: NIFXSG*SEGSIZ ;FIXNUM
SFLSIZ: NIFLSG*SEGSIZ ;FLONUM
DB$ SDBSIZ: 0 ;DOUBLE
CX$ SCXSIZ: 0 ;COMPLEX
DX$ SDXSIZ: 0 ;DUPLEX
BG$ SBNSIZ: NBNSG*SEGSIZ ;BIGNUM
SSYSIZ: NSYMSG*SEGSIZ ;SYMBOL
HN$ SHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS
SSASIZ: NSARSG*SEGSIZ ;SARS
IFN .-SFSSIZ-NFF, WARN [S--SIZ TABLE WRONG LENGTH]
;SIZES OF SPACES BEFORE START OF GC. COPIED FROM SFSSIZ ET AL. AT START OF GC.
OFSSIZ: 0 ;LIST
OFXSIZ: 0 ;FIXNUM
OFLSIZ: 0 ;FLONUM
DB$ ODBSIZ: 0 ;DOUBLE
CX$ OCXSIZ: 0 ;COMPLEX
DX$ ODXSIZ: 0 ;DUPLEX
BG$ OBNSIZ: 0 ;BIGNUM
OSYSIZ: 0 ;SYMBOL
HN$ OHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS
OSASIZ: 0 ;SARS
IFN .-OFSSIZ-NFF, WARN [O--SIZ TABLE WRONG LENGTH]
;SIZE FOR EACH SPACE BELOW WHICH TO GRAB NEW SEGMENTS FASTLY
.SEE SGCSIZE ; (I.E. WITHOUT DOING A WHOLE GARBAGE COLLECTION FIRST)
GFSSIZ: MAXFFS ;LIST
GFXSIZ: MAXFFX ;FIXNUM
GFLSIZ: MAXFFL ;FLONUM
DB$ GDBSIZ: MAXFFD ;DOUBLE
CX$ GCXSIZ: MAXFFC ;COMPLEX
DX$ GDXSIZ: MAXFFZ ;DUPLEX
BG$ GBNSIZ: MAXFFB ;BIGNUM
GSYSIZ: MAXFFY ;SYMBOL
HN$ GHNSIZ: REPEAT HNKLOG+1, MAXFFH ;HUNKS
GSASIZ: MAXFFA ;SARS
IFN .-GFSSIZ-NFF, WARN [G--SIZ TABLE WRONG LENGTH]
;FSSGLK FXSGLK FLSGLK SYSGLK SASGLK S2SGLK BTSGLK IMSGLK PRSGLK BTBAOB MAINBITBLT GC98 GC99 PFSSIZ PFXSIZ PFLSIZ PS2SIZ
;;; ROOTS OF THE CHAINS LINKING LIKE PAGES IN THE GARBAGE COLLECTOR
;;; SEGMENT TABLE (GCST). FILLED IN AT INIT TIME.
FSSGLK: 0 ;LIST
FXSGLK: 0 ;FIXNUM
FLSGLK: 0 ;FLONUM
DB$ DBSGLK: 0 ;DOUBLE
CX$ CXSGLK: 0 ;COMPLEX
DX$ DXSGLK: 0 ;DUPLEX
BG$ BNSGLK: 0 ;BIGNUM
SYSGLK: 0 ;SYMBOL
HN$ HNSGLK: REPEAT HNKLOG+1, 0 ;HUNKS
SASGLK: 0 ;SARS
IFN .-FSSGLK-NFF, WARN [--SGLK TABLE WRONG LENGTH]
S2SGLK: 0 ;THIS MUST FOLLOW THOSE ABOVE! (SYMBOL BLOCKS)
BTSGLK: 0 ;LINKED LIST OF BIT BLOCKS
IMSGLK: 0 ;LINKED LIST OF UNALLOCATED IMPURE SEGMENTS (INIT SETS UP)
PRSGLK: 0 ;LINKED LIST OF UNALLOCATED PURE SEGMENTS
10$ SVPRLK: 0 ;SAVED PRSGLK WHEN HISEG GETS PURIFIED
IFN LHFLAG, LHSGLK: 0 ;LINKED LIST OF BLOCKS FOR LH HACK
BTBAOB:
PG$ -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,,BFBTBS←<5-SEGLOG>
PG% -<NBITSG*SEGSIZ/BTBSIZ>+NBITB,, .SEE IN10S5
MAINBITBLT: BFBTBS-1 ;END ADDRESS FOR BLT OF MAIN BIT BLOCK AREA
GC98: 0 ;RANDOM TEMP FOR GC
GC99: 0 ;RANDOMER TEMP FOR GC
.SEE SPURSIZE ;SIZE OF PURE FREE STORAGE AREAS - USED MAINLY BY STATUS,
.SEE LDXQQ2 ; BUT ALSO RANDOMLY USED BY DEC-10 FASLOAD INTO HISEG
PFSSIZ: NPFSSG*SEGSIZ ;LIST
PFXSIZ: NPFXSG*SEGSIZ ;FIXNUM
PFLSIZ: NPFLSG*SEGSIZ ;FLONUM
DB$ PDBSIZ: 0 ;AIN'T NO INITIAL PURE DOUBLES, SONNY!
CX$ PCXSIZ: 0 ;AIN'T NO INITIAL PURE COMPLICES, MAMA!
DX$ PDXSIZ: 0 ;AIN'T NO INITIAL PURE DUPLICES, DADDY!
BG$ PBNSIZ: 0 ;AIN'T NO INITIAL PURE BIGNUMS, BABY!
0 ;AIN'T NEVER NO PURE SYMBOLS!
HN$ PHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS (YOU GOTTA BE KIDDING!)
0 ;AIN'T NEVER NO PURE SARS NEITHER!
IFN .-PFSSIZ-NFF, WARN [P--SIZ TABLE WRONG LENGTH]
PS2SIZ: NSY2SG*SEGSIZ ;SYMBOL BLOCKS
;BPSH BPSL HINXM HIXM MAXNXM HBPORG HBPEND NPDLL NPDLH PDLFL1 PDLFL2 XFFS XFFX XFFL XFFY XFFA XPDL XFLP XFXP XSPDL ZPDL ZFLP ZFXP ZSPDL C2 FLC2 FXC2 SC2 ZSC2 OC2 OFLC2 OFXC2 OSC2
;;; ********** HAIRY PARAMETERS HACKED BY ALLOC **********
BPSH: ;BINARY PROG SPACE HIGH
PG% 0 ;FILLED IN BY ALLOC
PG$ <<ENDLISP+PAGSIZ-1>&PAGMSK>-1
BPSL: BBPSSG ;BINARY PROG SPACE LOW
IFN PAGING,[
HINXM: 0 ;ADDRESS OF LAST WORD OF NXM HOLE
] ;END OF IFN PAGING
IFE PAGING,[
HIXM: 0 ;ADDRESS OF LAST WORD OF LOW SEGMENT
MAXNXM: 0 ;HIGHEST USABLE WORD OF NXM ABOVE LOW SEGMENT
HBPORG: ENDHI ;FIRST AVAILABLE WORD OF HISEG FOR LOADING BINARY PROGRAMS
HBPEND: IF1,[0] IF2,[HILOC+<<ENDHI-HILOC-STDHI+PAGSIZ-1>&PAGMSK>-1]
] ;END OF IFE PAGING
;;; THESE TWO VALUES ARE USED FOR A QUICK-AND-DIRTY PDL NUMBER CHECK.
.SEE PDLNMK
.SEE SPECBIND ;AND OTHERS
NPDLL: 0 ;LOW END OF NUMBER PDL AREA
NPDLH: 0 ;HIGH END OF NUMBER PDL AREA
IFN PAGING,[
PDLFL1: 0 ;FOR FLUSHING PDL PAGES - SEE ERINIT
PDLFL2: 0 ;FOR UPDATING ST - SEE ERINIT
] ;END OF IFN PAGING
;;; THE NEXT FEW THINGS MUST BE IN THIS ORDER
.SEE SSGCMAX ;MAXIMUM SIZES FOR STORAGE SPACES
XFFS: 0 ;LIST
XFFX: 0 ;FIXNUM
XFFL: 0 ;FLONUM
DB$ XFFD: 0 ;DOUBLE
CX$ XFFC: 0 ;COMPLEX
DX$ XFFZ: 0 ;DUPLEX
BG$ XFFB: 0 ;BIGNUM
XFFY: 0 ;SYMBOL
HN$ XFFH: REPEAT HNKLOG+1, MAXFFH ;HUNKS
XFFA: 0 ;SARS
IFN .-XFFS-NFF, WARN [XFF- TABLE WRONG LENGTH]
IFN PAGING,[
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
XPDL: MAXPDL ;MASTER PDL POSITIONS TO GIVE
XFLP: MAXFLP ; PDL-LOSSAGE INTERRUPTS AT
XFXP: MAXFXP
XSPDL: MAXSPDL
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
ZPDL: MAXPDL ;ACTUAL PDL POSITIONS FOR LOSING
ZFLP: MAXFLP ;INITIALIZED AT ERINIT FROM XPDL ET AL.
ZFXP: MAXFXP ; AND DIDDLED BY PDLOV AT OVERFLOW TIME
ZSPDL: MAXSPDL
] ;END OF IFN PAGING
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
C2: -PAGSIZ+NACS+1+2,,PDLORG-1 ;STANDARD REG PDL PTR
FLC2: -PAGSIZ+2,,FLPORG-1 ;STANDARD FLO PDL PTR
FXC2: -PAGSIZ+2,,FXPORG-1 ;STANDARD FIX PDL PTR
SC2: -PAGSIZ+1+2,,SPDLORG ;STANDARD SPEC PDL PTR
;SC2 IS INITIALIZED TO ONE SLOT HIGHER THAN MIGHT BE EXPECTED
; IN ORDER TO ACCOMMODATE A ONE-SLOT OVERPOP IN SOME PLACES.
.SEE ERRPOP
ZSC2: SPDLORG ;SC2 WITH ZERO LEFT HALF
;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER
OC2: 0 ;ABS LIMITS FOR PDLS
OFLC2: 0
OFXC2: 0
OSC2: 0
;INTAR UNRC.G UNRRUN UNRTIM UNREAR LIPSAV IPSWD1 IPSWD2 IPSDF1 IPSDF2 IPSPC IPSD IPSR IPSF MXIPDL LINTPDL INTPDL ACBASE INTPAR INTCLK INTTTI INTPOV INTILM INTNXM REEINT REENOP APRSVT REESVT INTALL %PIPAR %PIWRO %PIMPV %PIILO
SUBTTL RANDOM VARIABLES IN LOW CORE
;;; I GUESS THIS STUFF NEED NOT BE CONSIDERED SACRED
;;; SPACE FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS
MAYBE LINTAR==20+10*JOBQIO+5*USELESS+NFF
INTAR: 0 ;INDEX INTO INTERRUPT ARRAY (FIFO QUEUE)
BLOCK LINTAR ;ENTRIES OF FORM <INT #,,ARG FOR INT FN>
; RIGHT HALVES ARE PROTECTED BY GC
;;; ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS
MAYBE LUNREAR==20+10*JOBQIO+5*USELESS+NFF
UNRC.G: 0 ;-2/-3 FOR DELAYED ↑X/↑G INTERRUPT
IFN USELESS, UNRCLI: 0 ;ENTRY FOR DELAYED CLI INTERRUPT
IFN USELESS, UNRMAR: 0 ;ENTRY FOR DELAYED MAR INTERRUPT
UNRRUN: 0 ;ENTRY FOR DELAYED RUNTIME ALARMCLOCK
UNRTIM: 0 ;ENTRY FOR DELAYED REAL TIME ALARMCLOCK
UNREAR: 0 ;INDEX INTO "REAL TIME" INTERRUPT QUEUE
BLOCK LUNREAR ;ENTRIES OF FORM <ARG FOR INT FN,,INT #>
;ARGS IN UNREAR NEED NO GC PROTECTION
.SEE NOINTERRUPT
;;; INTERRUPT PDL
LIPSAV==:10 ;LENGTH OF CRUD PUSHED BY INTERRUPT
IPSWD1==:-7 ;WORD ONE (.PIRQC) INTERRUPTS TAKEN
IPSWD2==:-6 ;WORD TWO (.IFPIR) INTERRUPTS TAKEN
IPSDF1==:-5 ;SAVED .DF1
IPSDF2==:-4 ;SAVED .DF2
IPSPC==:-3 ;SAVED PC
IPSD==:-2 ;SAVED ACCUMULATOR D
IPSR==:-1 ;SAVED ACCUMULATOR R
IPSF==:0 ;SAVED ACCUMULATOR F
MXIPDL==4 ;MAX SIMULTANEOUS INTERRUPTS
; (CALCULATED FROM THE DEFER WORDS
; IN THE INTERRUPT VECTOR):
; 1 MISCELLANEOUS
; 2 PDL OVERFLOW
; 1 MEMORY ERROR/ILLEGAL OP
INTFOO: 0 ;BH
LINTPDL==LIPSAV*MXIPDL+1 .SEE PDLOV
INTPDL: -LINTPDL,,INTPDL .SEE INTVEC
;EXTRA ROOM FOR ONE INTPDL OVERFLOW AND RESULTING EXTRA INTERRUPT
BLOCK LINTPDL+2*LIPSAV .SEE PDLOV
IT$ IOCINS: 0 ;USER IOC ERROR ADDRESS
IT$ .SEE IOCER8
IFN D10,[
IFN SAIL,[
;SAIL ONLY DEFINITIONS
ACBASE==:20 ;WHERE SAIL MONITOR SAVES USER ACS UPON INT
INTPAR==:000400,,000000 ;PARITY ERROR
INTCLK==:000200,,000000 ;CLOCK INTERRUPT
INTTTI==:000004,,000000 ;<ESCAPE>I INTERRUPT
INTPOV==:000000,,200000 ;PDL OV
INTILM==:000000,,020000 ;ILL MEMORY REF
INTNXM==:000000,,010000 ;NON EXISTANT MEMORY
] ;END IFN SAIL
REEINT: BLOCK 1
REENOP: BLOCK 1
APRSVT: BLOCK 1
REESVT: BLOCK 1
] ;END IFN D10
IFN D10+D20,[
INTALL: BLOCK 1
;FUDGE BIT DEFINITIONS FOR VARIOUS ITS PI BITS
;LEFT HALF BITS
%PIPAR==:1000,,
%PIWRO==:200,,
;RH BITS
%PIMPV==:20000
%PIILO==:40
] ;END IFN D10+D20
;MUNGP ERRPAD ERRPST BFTMPS SQ6BIT SQSQOZ LDBYTS LDOFST LDAAOB LDTEMP LD6BIT LDAPTR LDBPTR LDF2DP LDASAR LDBSAR LDXBLT LDXSIZ LDXSM1 LDXDIF LDHLOC LDEOFJ LFTMPS LDHSH2 LDHSH2 LDHSH2 LDX%FU LDXPSP LDXOFS LDXPNT LDXLPC LDXLPL LDXHS1 LDXHS2 LDXPFG
;MUNGP ERRPAD ERRPST BFTMPS SQ6BIT SQSQOZ LDBYTS LDOFST LDAAOB LDTEMP LD6BIT LDAPTR LDBPTR LDF2DP LDASAR LDBSAR LDXBLT LDXSIZ LDXSM1 LDXDIF LDHLOC LDEOFJ LFTMPS LDHSH2 LDHSH2 LDHSH2 LDX%FU LDXPSP LDXOFS LDXPNT LDXLPC LDXLPL LDXHS1 LDXHS2 LDXPFG
;;; LH OF MUNGP => GC IS IN PROCESS OF USING MARK BITS
;;; IN SARS OR SYMBOLS
;;; RH OF MUNGP => ALIST IS IN PROCESS OF USING LH'S OF
;;; VALUE CELLS FOR SPECPDL HACKERY
;;; ERINIT CHECKS MUNGP AND ATTEMPTS TO RESTORE THINGS IF
;;; NECESSARY. THIS SHOULD HAPPEN ONLY IN THE CASE OF SOME
;;; GROSS BUG LIKE A MEMORY VIOLATION.
MUNGP: 0
;;; VARIABLES NEEDED FOR ERRPOP
ERRPAD: 0 ;SAVE RETURN ADDRESS
ERRPST: 0 ;SAVE T OVER UNWPRO
;;; TEMPORARIES FOR FASLOAD
BFTMPS::
SQ6BIT: 0 ;TEMPORARIES FOR SQUEEZE
SQSQOZ: 0
LDBYTS: 0 ;WORD OF RELOCATION BYTES
LDOFST: 0(TT) ;LOAD OFFSET (RELOCATION FACTOR = VALUE OF BPORG BEFORE LOAD)
LDAAOB: 0 ;AOBJN INDEX FOR ATOMTABLE ARRAY
LDTEMP: ;RANDOM TEMPORARY
LD6BIT: 0 ;PLACE TO ACCUMULATE SIXBIT WHILE CONVERTING FROM SQUOZE
; - FIRST 6 BITS OF NEXT WORD MUST BE ZERO
LDAPTR: 0(TT) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE ATOMTABLE
LDBPTR: 0(F) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE I/O BUFFER
LDF2DP: 0 ;.FNAM2-DIFFERENT-P
; (NON-ZERO --> FASLAP'S LDFNM2 DIFFERS FROM CURRENT FASLOAD'S)
LDASAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S ATOMTABLE ARRAY
LDBSAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S I/O BUFFER ARRAY
IFE PAGING,[
LDXBLT: 0 ;BLT POINTER FOR ZAPPING CALLS FOR XCTS IN BPS
LDXSIZ: 0 ;0=XCT HACKERY NEVER DONE, -1=DONE AND PURIFIED,
; N>0=LENGTH (IN WORDS) OF AREA FOR XCTED CALLS
LDXSM1: 0 ;CONTAINS 1 LESS THAN LDXSIZ, AND RETAINS VALUE AFTER
; LDXSIZ BECOMES -1
LDXDIF: 0(D) .SEE LDPRC6
;RH WILL CONTAIN DIFFERENCE BETWEEN RH AND LH OF LDXBLT
] ;END IFE PAGING
LDHLOC: 0 ;HIGHEST LOC ASSEMBLED INTO + 1
LDEOFJ: 0 ;JUMP ADDRESS FOR END OF FASLOAD INPUT FILE
10$ LDEOFP: 0 ;USED FOR EOF HANDLING IN FASLOAD FOR D10
LFTMPS==:.-BFTMPS ;NUMBER OF FASLOAD TEMPORARIES
IFN PAGING,[
;MULTIPLE XCT SEGMENTS ASSEMBLY TIME PARAMETERS
;DESCRIPTION OF SEGMENT FORMAT:
;LDXPNT POINTS TO FIRST IMPURE SEGMENT IN THE CHAIN. THE RH OF LDXPSP
; WORD IN EACH SEGMENT IS THE POINTER TO THE PURIFIABLE SEGMENT ATTACHED
; TO THE IMPURE SEGMENT, AND THE LH OF LDXPSP IS THE POINTER TO THE NEXT
; SEGMENT OR 0 IF NO MORE SEGMENTS IN CHAIN. LDXLPC IS THE -COUNT OF THE
; NUMBER OF SLOTS FREE IN THE CURRENT SEGMENT. THE CURRENT SEGMENT IS THE
; ONE POINTED TO BY LDXLPL. IF LDXLPC IS >= 0, IT IS POSSIBLE THAT THE PURE
; SEGMENT ATTACHED TO C(LDXLPL) IS ACTUALLY PURE, AND THUS MAY NOT BE WRITTEN
; INTO. IF LDXPNT IS 0, THE DATABASE IS COMPLETELY INVALID.
; THE SEGMENT SIZE USED IS THE DEFAULT SEGMENT SIZE DEFINED BY SEGLOG AND
; SEGSIZ. IF LDXPFG IS -1, THEN A PURIFICATION HAS BEEN DONE. THIS FLAG IS
; USED SOLELY FOR (STATUS UUOLINKS). AN EMPTY SLOT IS ZERO IN BOTH THE PURE
; AND IMPURE SEGMENT. THE FIRST WORD THAT IS USED FOR DATA IN EACH SEGMENT
; IS LDXOFS. THIS IS COMPUTED SUCH THAT THE LAST WORD OF DATA IS ACTUALLY THE
; LAST WORD OF THE SEGMENT.
;HASHING VALUES
IFE SEGLOG-8.,[LDHSH1==:251.
LDHSH2==:241.]
IFE SEGLOG-9.,[LDHSH1==:509.
LDHSH2==:503.]
IFE SEGLOG-10.,[LDHSH1==:1019.
LDHSH2==:1021.]
LDX%FU==:90. ;WHAT PERCENTAGE FULL ANY PAGE IS ALLOWED TO GET
;THIS MUST BE LOCATION ZERO!
LDXPSP==:0 ;NEXT SEGMENT IN CHAIN,,PURE SEGMENT POINTER
LDXOFS==:SEGSIZ-LDHSH1-1 ;OFFSET OF FIRST WORD OF UUOLINKS
LDXPNT: 0 ;POINTER TO XCT PAGES
LDXLPC: 0 ;COUNT OF WORDS REMAINING ON LAST PAGE USED
LDXLPL: 0 ;STARTING LOCATION OF LAST PAGE USED
LDXHS1: 0 ;FIRST HASH VALUE
LDXHS2: 0 ;SECOND HASH VALUE
LDXPFG: 0 ;-1 WHEN PURIFIED
] ;END IFN PAGING
;USN EVPUNT UWUSN D10PTR D10ARD D10NAM D10REN SYMLO %TXTOP %TXSFL %TXSFT %TXMTA %TXCTL %TXASC RDOBJ8 ALGCF AFILRD GNUM RNOWS RBACK RBLOCK
IT$ IUSN: 0 ;INITIAL USER SNAME - SET BY LISPGO
USN: BLOCK 2 ;USER SYSTEM NAME
EVPUNT: TRUTH ;DON'T EVAL FUNCTION ATOM
IFN D10,[
UWUSN: 0 ;UWRITE SNAME (I.E. PPN)
D10PTR: 0 ;AOBJN POINTER FOR DEC BUFFERS..
D10ARD: -200,,. ;I/O WORD FOR ARRAY DUMP AND FASL
0
D10NAM: 0 ;THIS WORD ;WILL BE ###LSP WHERE ###=JOB NR
D10REN: BLOCK 2 ;FILE NAME TO
SYMLO: 0 ;LOW BOUNDARY FOR DDT'S SYMBOL TABLE
] ;END OF IFN D10
IFN SAIL,[
;DEFINE SOME EXTRA TTY RELATED BITS
%TXTOP==:4000 ;"TOP" KEY.
%TXSFL==:2000 ;"SHIFT-LOCK" KEY.
%TXSFT==:1000 ;"SHIFT" KEY.
%TXMTA==:400 ;"META" KEY.
%TXCTL==:200 ;"CONTROL" KEY.
%TXASC==:177 ;THE ASCII PART OF THE CHARACTER.
] ;END IFN SAIL
RDOBJ8: RD8N ;OR RD8W FOR WHITE'S + HAC
ALGCF: 0 ;FLAG TO STOP THE GC WHILE IN ALLOC
AFILRD: -1 ;-1 => NO INIT FILE, >0 => CDR OF ALLOC COMMENT
GNUM: ASCII \G0000\ ;INITIAL GENSYM
;;; RANDOM STUFF FOR RANDOM NUMBER GENERATOR
;;; RNOWS, RBACK, AND RBLOCK MUST BE IN THAT ORDER.
IFN USELESS,[
MAYBE LRBLOCK==:71. ; 71 35
MAYBE ROFSET==:35. ;X +X +1 IS IRREDUCIBLE MOD 2 (ASK MACSYMA!)
] ;END OF IFN USELESS
IFE USELESS,[
MAYBE LRBLOCK==:7 ; 7 3
MAYBE ROFSET==:3 ;SO ALSO IS X +X +1 IRREDUCIBLE MOD 2
] ;END OF IFE USELESS
RNOWS: 0 .SEE INIRND ;INITIALIZED AT INIT TIME
RBACK: 0 .SEE SSRANDOM ;CAN BE RESTORED BY (SSTATUS RANDOM ...)
RBLOCK: BLOCK LRBLOCK .SEE RANDOM ;BLOCK OF RANDOM CRUD
;RNTN2 BPPNR GAMNT GSBPN ADDSAR TOTSPC LLIP1 INSP RTSP1 RTSP3 LOSEF RWG FLOV9A FLOV9B CPJSW PSYMF POFF PSMS PSMTS PSMRS PS.S STQLUZ NOPFLS SAWSP PURDEV PURFN1 PURFN2 PURSNM SYSDEV SYSFN1 SYSFN2 SYSSNM
RNTN2: .(T) ;CURRENT PNBUF WORD FOR COMPARE ON INTERN
;;; VARIABLES FOR ARRAY ALLOCATOR
BPPNR: 0 ;<SIZE OF ARRAY HEADER>,,-<SIZE OF ARRAY DATA>
GAMNT: 0 ;NUMBER OF WORDS REQUIRED, ON A CALL TO GETSP
GSBPN: 0 ;USED AS TEMPORARY BPEND WHILE BLT'ING DOWN ARRAYS
ADDSAR: 0 ;ADDRESS OF SPECIAL ARRAY CELL WHEN MAKIN ARRAY
TOTSPC: 0 ;<# OF ARRAY DIMS>,,<TOTAL SPACE NEEDED FOR ARRAY>
LLIP1: 0 ;<LARGEST LEGAL INDEX OF ARRAY>+1
INSP: 0 ;PSEUDO-PDL POINTER FOR ARRAY-ING
RTSP1: 0
RTSP3: 0
LOSEF: 77 ;LAP OBJECT STORAGE - EFFICIENCY FACTOR. FOR (STATUS LOSEF) = N,
;THERE WILL BE <1←N>-1 STORED HERE. SIZE OF GC PROTECTION ARRAY
RWG: 0 ;IF = 0, THEN CREATE ERROR ON DIVIDE BY ZERO,
;OR FLOATING OVFLO ON CONVERSION OF BIGNUM
FLOV9A: 0 ;RANDOM TEMPS FOR FLOATING POINT
FLOV9B: 0 ; OVERFLOW INTERRUPT HANDLER
CPJSW: 0 ;IF NOT ZERO, THEN *RSET WAS ON, AND BAKTRACE WILL FIND MUCH
;INFORMATION FROM THE [FUN,,CPOPJ] TYPE STUFF ON THE PDL
PSYMF: 0 ;NON-ZERO DURING EXECUTION OF PSYM.
POFF: 0 ;VARIOUS ROUTINES INVOLVING $X'S FROM DDT DO JSR'S HERE
JRST PSYM1
PSMS: BLOCK 20 ;THIS SHOULD BE ENOUGH FOR LPSMTB
BLOCK 3
PSMTS: 0
PSMRS: 0
IT$ SQUOZE 0,. ;FOR A .BREAK 12,[4,,PS.S-1]
PS.S: 0 .SEE PSYM1
STQLUZ: 0 ;FOR SETQING NIL OR T - REMEMBER WHICH ONE OVER INTWAIT
NOPFLS: 0 ;NON-ZERO => PURIFY$G SHOULDN'T FLUSH PDLS
SAWSP: -1 ;SCREW-AROUND-WITH-SHARING-P
IFN ITS,[
PURDEV: 0 ;PDUMP FILE DEVICE NAME
PURFN1: 0 ;PDUMP FILE FN1
PURFN2: 0 ;PDUMP FILE FN2
PURSNM: 0 ;PDUMP FILE SNAME
SYSDEV: SIXBIT \SYS\
SYSFN1: SIXBIT \PURQIO\
SYSFN2: LVRNO
SYSSNM: SIXBIT \SYS\
] ;IFN ITS
;KILHG4 KILHG2 KILHG3 KILHGH KILHG1 KILHG1 KILHG2 GETHGH GETHG1 GETHG2 GETHG1 RETHGH GLSLUY GLSLUA CHKHGH GLSLZ4 GLSLZ0 GLSLZA GLSLZ1 GLSLM1 GLSLZ2 GLSLM2 GLSLZ3 GLSLM3 SGANAM SGADEV SGAPPN SGAEXT LDRIHS LDRHS1 LDSCRU SJCLBUF
SUBTTL KILHGH AND GETHGH
IFN D10*HISEGMENT,[
IFE SAIL,[
KILHG4: OUTSTR [ASCIZ \
;Not flushing high segment - can't find .SHR file
\]
KILHG2: MOVEI A,KILHG3 ;THIS SHOULD BE START ADR IF NOT KILLING HS
HRRM A,.JBSA
MOVE 0,SGANAM ;IMPORTANT INFO INTO ACS IN CASE OF CONTINUE
MOVE 11,SGADEV
MOVE 7,SGAPPN
EXIT 1, ;SUSPEND FOR A WHILE
KILHG3: MOVEM 0,SGANAM
MOVEM 11,SGADEV
MOVEM 7,SGAPPN
JRST RETHGH
] ;END IFE SAIL
KILHGH: MOVEI A,GETHGH ;KILL HIGH SEGMENT
HRRM A,.JBSA" ;SET START ADDRESS
IFE SAIL,[
SKIPN SUSFLS
JRST KILHG2
SKIPE SGANAM ;CAN'T FLUSH HIGH SEGMENT IF WE
SKIPN SGADEV ; DON'T KNOW WHEREFROM TO RETRIEVE IT
JRST KILHG4
MOVSI A,1
CORE A, ;FLUSH HIGH SEGMENT
JFCL
KILHG1:
] ;END OF IFE SAIL
IFN SAIL,[
SKIPE SUSFLS
SKIPN SGANAM
JRST KILHG1
MOVEI A,FAKDDT ;FOO, HOW MANY WAYS CAN SAIL LOSE?
SKIPN .JBDDT ; JOBDDT MUST BE NON-ZERO TO SAVE!
SETDDT A, ; OTHERWISE MAY FAIL TO SAVE ENTIRE LOSEG
SETZ A,
CORE2 A, ;FLUSH HIGH SEGMENT
HALT ;HOW CAN WE POSSIBLY LOSE? (HA HA)
JRST KILHG2
KILHG1: SKIPL .JBHRL
JRST KILHG2
MOVEI A,1
SETUWP A,
HALT
KILHG2:
] ;END OF IFN SAIL
EXIT 1, ;"CONTINUE" WILL FALL INTO GETHGH
GETHGH:
IFE SAIL,[
MOVEI A,A+1 ;SET UP TO GET HIGH SEG BACK
MOVE A+1,SGADEV
MOVE A+2,SGANAM
MOVE A+3,SGAEXT
MOVEI A+4,0
MOVE A+5,SGAPPN
SKIPE SGANAM
SKIPN SGADEV
JRST GETHG1
GETSEG A, ;GET HIGH SEGMENT
JRST GLSLUA
GETHG1:
] ;END OF IFE SAIL
IFN SAIL,[
RESET
SKIPE .JBHRL
JRST GETHG1
MOVE T,SGANAM
ATTSEG T,
SKIPA TT,SGADEV
JSP FREEAC,CHKHGH
MOVEI T,.IODMP ;ON FAILURE, LOCK THE SHR FILE, THEN TRY AGAIN,
SETZ D, ; AND ON FAILING MAKE THE HISEG OURSELVES
OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE
HALT ;SOME MORON GAVE LOSING SECOND ARG TO SUSPEND?
MOVE T,SGANAM
MOVE TT,SGAEXT
SETZ D,
GETSTS TMPC,R ;GET CHANNEL STATUS WORD
TDO R,1000 ;FAST READ-ALTER
SETSTS TMPC,(R) ;DO IT
MOVE R,SGAPPN
LOOKUP TMPC,T
JRST GLSLUA ;LOOK UP .SHR FILE
MOVS F,R
TRZ TT,-1 ;WE NOW OPEN IT FOR READ-ALTER MODE FOR
SETZ D, ; THE SOLE PURPOSE OF PREVENTING OTHER
MOVE R,SGAPPN ; JOBS FROM READING IT TOO, THEREBY
ENTER TMPC,T ; CAUSING WEIRD RACE CONDITIONS
JRST GLSLUA
MOVE T,SGANAM
ATTSEG T, ;SEE IF SOMEONE ELSE HAS SAME HISEG; THIS CAN
SKIPA T,F ; HAPPEN IF SOME OTHER JOB GETS THROUGH THIS
JSP FREEAC,CHKHGH ; CODE BETWEEN OUR FIRST ATTSEG AND THE ENTER
MOVNS T ;T GETS LENGTH OF .SHR FILE
ADD T,.JBREL
HRR R,.JBREL ;MUST GOBBLE SOME COPIES OF .JBREL
HRRZ TT,.JBREL ; BEFORE THE CORE UUO CHANGES IT
CORE T, ;EXTEND LOSEG BY THIS AMOUNT
JRST GLSLZ1
SETZ F,
IN TMPC,R ;READ IN HISEG
SKIPA T,SGANAM
JRST LDSCRU
TLO TT,400000 ;WRITE PROTECT HISEG
GETHG2: REMAP TT, ;LET'S SPLIT
JRST GLSLZ3
GETHG1:
MOVE T,SGANAM
SETNM2 T,
HALT
RELEASE TMPC, ;FLUSH TEMP CHANNEL *AFTER* CREATING THE HISEG
] ;END OF IFN SAIL
JSP F,JCLSET ;GOBBLE DOWN ANY JCL
RETHGH: JRST . ;RETURN ADDR CLOBBERED IN HERE
GLSLUY: SIXBIT \CANNOT GET HIGH SEGMENT!\
GLSLUA: MOVEI C,GLSLUY
IFN SAIL,[
RELEASE TMPC,
TLZ TT,-1
CAIE TT,ERFBM% ;COLLISION DUE TO LOCKOUT?
JRST GLSLZ0 ;NO, GENUWINE LOSSAGE
PJOB TT, ;THIS IS ALL PRETTY RANDOM - WE'RE
IDIVI TT,7 ; TRYING JUST A LITTLE BIT TO SOLVE
SLEEP D, ; THE HAIRY RACE CONDITIONS (ALOHA!)
JRST GETHGH
CHKHGH: MOVE D,SGAPPN
CAME D,PSGPPN
JRST GLSLZ4
MOVE D,SGADEV
CAME D,PSGDEV
JRST GLSLZ4
MOVE D,SGAEXT
CAME D,PSGEXT
JRST GLSLZ4
MOVE D,SGANAM ;CHECK HISEG VALIDATION WORDS
CAME D,PSGNAM
JRST GLSLZ4
JRST GETHG1
GLSLZ4: SETZ T, ;WRONG HISEG, SO ZERO IT OUT AND START AGAIN
CORE2 T,
JRST GLSLZ1
MOVE TT,SGADEV
MOVE T,F
JRST (FREEAC)
GLSLZ0:
] ;END OF IFN SAIL
HRLI C,440600 ;WILL READ A SIXBIT STRING
GLSLZA: ILDB T,C ;READ STRING AND TYPE IT
ADDI T," " ;CONVERT TO ASCII
OUTCHR T
CAIE T,"!" ;STOP AFTER EXCLAMATION-POINT
JRST GLSLZA
EXIT ;FOO
IFN SAIL,[
GLSLZ1: OUTSTR GLSLM1
EXIT
GLSLM1: ASCIZ \?CORE UUO LOST
\
GLSLZ2: OUTSTR GLSLM2
EXIT
GLSLM2: ASCIZ \?IN UUO LOST
\
GLSLZ3: OUTSTR GLSLM3
JRST GETHG2
GLSLM3: ASCIZ \?REMAP lost -- no job slots available, retrying
\
] ;END OF IFN SAIL
SGANAM:
SA% 0 ;THESE ARE THE SAVED NAMES FOR GETTING
SA$ SIXBIT \MACLSP\
SGADEV:
SA% 0 ; THE HIGH SEGMENT BACK AFTER SUSPENSION
SA$ SIXBIT \SYS\
SGAPPN: 0 .SEE SUSPEND
SGAEXT: SIXBIT \SHR\ ;SOME LOSER MIGHT WANT TO CHANGE THIS
;;; CODE FOR FASLOAD TO READ IN A NEW HIGH SEGMENT.
;;; THIS CODE MUST BE IN THE LOW SEGMENT!
;;; T HAS LENGTH OF THE .SHR FILE; LH(R) HAS NEGATIVE OF THIS.
LDRIHS:
IFE SAIL,[
MOVSI TT,1
CORE TT, ;FLUSH OLD HIGH SEGMENT
JRST LDSCRU
HRRZ TT,.JBREL ;CURRENT HIGHEST ADDRESS IN LOSEG
HRRZ D,.JBREL
HRR R,.JBREL
ADD TT,T
CORE TT, ;EXPAND LOSEG SO CAN HOLD COPY OF HISEG
JRST LDSCRU ; (REMEMBER, CAN'T DO I/O INTO HISEG!)
SETZ F,
IN TMPC,R ;READ IN .SHR FILE
CAIA
JRST LDSCRU
REMAP D, ;NOW MAKE A HISEG FROM THE READ-IN CODE
JRST LDSCRU
SETUWP F, ;TOPS-10 PROTECTS US FROM OURSELVES,
JRST LDSCRU ; SO WE MUST MAKE HISEG WRITABLE (F IS ZERO)
SETZM SGANAM ;WE NO LONGER KNOW THE HIGHSEG NAME!
;IF THIS IS NON-ZERO, HIGH-SEG GETS FLUSHED
; DURING (SUSPEND) AND ALL THE STUFF WE'VE
; DONE TO IT GOES BYEBYE! (ARG!)
POPJ P,
] ;END OF IFE SAIL
IFN SAIL,[
SETZ TT,
CORE2 TT, ;FLUSH OLD HIGH SEGMENT
JRST LDSCRU
LDRHS1: CORE2 T, ;MAKE A NEW (WRITABLE) HISEG THAT BIG
JRST LDSCRU
MOVE T,D10NAM ;USE D10NAM AS HISEG NAME TO MAKE HISEG UNIQUE
LSH T,-6 ;AS LONG AS WE'RE BEING RANDOM...
SETNM2 T, ;TRY TO SET NAME FOR HIGH SEGMENT
JFCL
HLRE T,R ;GET WORD COUNT SING EXTENDED
MOVMS T ;AND MUST GET A HI-SEG THAT BIG
HRRI R,400000-1
SETZ F,
IN TMPC,R ;READ IN HISEG
POPJ P, ;RETURN TO CODE IN HISEG
] ;END OF IFN SAIL
LDSCRU: OUTSTR [ASCIZ \DEPURIFYING HISEG LOST - YOU ARE STRANDED!
\]
SA% EXIT
SA$ JRST LDRHS1
] ;END OF IFN D10*HISEGMENT
SA$ FAKDDT: HALT ;FOR FAKING OUT THE WORLD
MAYBE LSJCLBUF==10 ;ENOUGH FOR 40. CHARS
SJCLBUF: 0 ;FIRST WORD HOLD NUMBER OF CHARS BUFFERED
BLOCK LSJCLBUF
0 ;INSURES THAT ILDBS WILL FINALLY SEE A ZERO
;RSXTB1 RCT IOBAR1 IOBAR2 PURTBL ZZW ZZZ $ NLBTSG NHBTSG ZZX ZZX ZZZ FLSTBL ZZX ZZX
SUBTTL INITIAL READTABLE, OBARRAY (IN LOW CORE), AND PURTBL
;;; INITIAL READ SYNTAX TABLE IN FORM OF AN ARRAY
-1,,0 ;IN NEWIO, WILL POINT TO MACRO CHAR LIST
RSXTB1: PUSH P,CFIX1
JSP TT,1DIMF
READTABLE
0
RCT: BLOCK LRCT-2 ;WHICH IS BLT'D IN FROM RCT0
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; INITIAL OBLIST IN FORM OF ARRAY
-<OBTSIZ+1>/2,,IOBAR2
IOBAR1: JSP TT,1DIMS
OBARRAY
OBTSIZ+1+200
IOBAR2: BLOCK <OBTSIZ+1>/2
BLOCK 200/2 ;SINGLE CHAR OBJS TABLE (CREATED AS NEEDED)
;;; PURE PAGE TABLE
;;; CONTAINS TWO BITS FOR EACH PAGE, 16 PAGES PER TABLE WORD
;;; MEANING OF BITS: 00=NXM 01=IMPURE
;;; 10=PURE 11=SPECIAL HACKERY NEEDED
IFN PAGING,[
PURTBL:
IF1,[
BLOCK NPAGS/20
IFN NPAGS&17, BLOCK 1
] ;END IF1
IF2,[
ZZW==. ;DARN WELL BETTER BE SAFE OVER THE FOLLOWING MESS!
.BYTE 2
ZZZ==0
$==3 ;FOR HAIRY PRINTOUT TO WORK
PRINTX \
INITIAL PURTBL MEMORY LAYOUT
[0=NXM, 1=IMPURE, 2=PURE, $=BPS/PDL/SCRATCH]
\
NLBTSG==0
NHBTSG==0
IFN LOBITSG, NLBTSG==NBITSG
.ELSE, NHBTSG==NBITSG
;;; IN THE IRP BELOW, COMMAS AND CR'S MARK GUARANTEED PAGE BOUNDARIES
IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
BITS
ZZZ==ZZZ+1
IFE ZZZ&17,[
0
0
]
PRINTX \BITS\
IFE <ZZZ#10>&17, PRINTX \ \
IFE <ZZZ#20>&37, PRINTX \ \
IFE ZZZ&37,[
PRINTX \
\
]
] ;END OF REPEAT
TERMIN
.BYTE
IFN ZZZ-NPAGS,[
WARN \ZZZ,[=WRONG LENGTH FOR PURTBL (SHOULD BE ]\NPAGS,[)]
LOC ZZW
] ;END OF IFN ZZZ-NPAGS
PRINTX \
\
] ;END IF 2
FLSTBL:
IF1, BLOCK <<777777←-SEGLOG>+1>/36.
IF2,[
.BYTE 1
IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP
IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP
SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$]
ZZX==0
IRPS SPC,,[SPCS]
ZZX==ZZX+N!SPC!SG
TERMIN
REPEAT ZZX/SGS%PG,[
IFE BITS-2, 1 ;GENERATE A FLUSH ENTRY IF PURE
.ELSE, 0 ; ELSE PAGE SHOULD NOT BE FLUSHED
]
TERMIN
.BYTE
BLOCK <<777777←-SEGLOG>+1>/36.-<.-FLSTBL>
] ;END OF IF2
] ;END OF IFN PAGING
;ZZ LOBITSG TOP.PG BTBLKS LOBITSG
SUBTTL OLD I/O BUFFERS, PATCH AREAS
CONSTANTS
;;; NO MORE CONSTANTS PERMITTED AFTER THIS IN THE LOSEG (WRITEABLE FIRST PAGE)
10% LOPATCH==0
10$ LOPATCH==0
IF1,[
ZZ==.
LOBITSG==0 ;NON-ZERO ==> BITSGS ARE LOW
PAGEUP
TOP.PG==.
IFGE TOP.PG-ZZ-SEGSIZ,[ ;SEE IF THERE IS ANOTHER SEGMENT LEFT ON THIS PAGE
SEGUP ZZ
SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
SPCBOT BIT
BTBLKS: BLOCK BTSGGS*SEGSIZ-1
SEGUP .
SPCTOP BIT,ST,[BIT BLOCK]
IFE TOP.PG-., LOBITSG==1
.ELSE,[
WARN [LOBITSG STUFF DIDN'T WORK]
EXPUNGE NZERSG NBITSG BBITSG
EXPUNGE BTBLKS
LOBITSG==0
] ;END OF .ELSE
] ;END OF IFGE TOP.PG-ZZ-SEGSIZ
] ;END OF IF1
IF2,[
IFN PAGING, PAGEUP
IFE PAGING, SEGUP .
] ;END OF IF2
IFE LOBITSG, SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)]
PG% EXPUNGE BZERSG
EXPUNGE TOP.PG
;ST STDISP
SUBTTL SEGMENT TABLES
;;; FORMAT OF SEGMENT TABLE (<NSEGS> WORDS, ONE FOR EACH SEGMENT)
;;; 4.9 LS 1=LIST STRUCTURE, 0=ATOMIC
;;; 4.8 $FS FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.7 FX FIXNUM STORAGE
;;; 4.6 FL FLONUM STORAGE
;;; 4.5 BN BIGNUM HEADER STORAGE
;;; 4.4 SY SYMBOL HEADER STORAGE
;;; 4.3 SA SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO)
;;; 4.2 VC VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO)
;;; 4.1 $PDLNM NUMBER PDL AREA
;;; (ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO)
;;; 3.9 RESERVED - AVOID USING (FORMERLY $FLP)
;;; 3.8 $XM EXISTENT (RANDOM) AREA
;;; 3.7 $NXM NONEXISTENT (RANDOM) AREA
;;; 3.6 PUR PURE SPACE (ONE OF BITS 4.8-4.5 OR 3.8 SHOULD BE ON)
;;; 3.5 HNK HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO)
;;; 3.4 DB DOUBLE-PRECISION FLONUMS ;THESE ARE
;;; 3.3 CX COMPLEX NUMBERS ; NOT YET
;;; 3.2 DX DOUBLE-PRECISION COMPLEX NUMBERS ; IMPLEMENTED
;;; 3.1 UNUSED
;;; 2.9-1.1 ADDRESS OF A DATA TYPE, ATOM:
;;; QLIST, QFIXNUM, QFLONUM, QBIGNUM,
;;; QSYMBOL, QRANDOM, QARRAY, QHUNK<N>
;;; NOTE THAT THESE ATOMS OCCUPY CONSECUTIVE MEMORY
;;; LOCATIONS AND THUS NUMERICALLY ENCODE THE PAGE TYPE.
;;; THIS COMMENT SHOULD BE KEPT CONSISTENT WITH THE DEFINITIONS (IN THE
;;; DEFNS FILE) FOR THE ABOVE SYMBOLS, AND WITH LOCATION PSYMTT.
.SEE LS
.SEE PSYMTT
SPCBOT ST
ST: ;SEGMENT TABLE
IFE PAGING, BLOCK NSEGS ;FOR PAGING SYSTEM, CODE IN INIT SETS UP
; THESE TABLES AT RUN TIME.
IFN PAGING,[
IF1, BLOCK NSEGS
IF2,[
STDISP: EXPUNGE STDISP ;FOR .SEE
$ST ZER,$XM ;"ZERO" (LOW IMPURE) SEGMENTS
IFN LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST ST,$XM ;SEGMENT TABLES
$ST SYS,$XM+PUR ;SYSTEM CODE
$ST SAR,SA ;SARS (ARRAY POINTERS)
$ST VC,LS+VC ;VALUE CELLS
$ST XVC,$NXM ;RESERVED FOR EXTRA VALUE CELLS
$ST IS2,$XM ;IMPURE SYMBOL BLOCKS
$ST SYM,SY ;SYMBOL HEADERS
$ST XXA,$XM ;SLACK SEGMENTS (IMPURE!)
$ST XXZ,$NXM ;SLACK SEGMENTS (INITIALLY NXM)
$ST SY2,$XM+PUR ;PURE SYMBOL BLOCKS
$ST PFX,FX+PUR ;PURE FIXNUMS
$ST PFS,LS+$FS+PUR ;PURE FREE STORAGE (LIST)
$ST PFL,FL+PUR ;PURE FLONUMS
$ST XXP,$XM+PUR ;SLACK PURE SEGMENT (FOOEY!)
$ST IFS,LS+$FS ;IMPURE FREE STORAGE (LIST)
$ST IFX,FX ;IMPURE FIXNUMS
$ST IFL,FL ;IMPURE FLONUMS
IFN BIGNUM, $ST BN,BN ;BIGNUMS
$ST XXB,$XM ;SLACK SEGMENTS (IMPURE!)
IFE LOBITSG, $ST BIT,$XM ;BIT BLOCKS
$ST BPS,$XM ;BINARY PROGRAM SPACE
$ST NXM,$NXM ;(INITIALLY) NON-EXISTENT MEMORY
$ST FXP,FX+$PDLNM ;FIXNUM PDL
$ST XFXP,$NXM ;FOR FXP EXPANSION
$ST FLP,FL+$PDLNM ;FLONUM PDL
$ST XFLP,$NXM ;FOR FLP EXPANSION
$ST P,$XM ;REGULAR PDL
$ST XP,$NXM ;FOR P EXPANSION
$ST SP,$XM ;SPECIAL PDL
$ST XSP,$NXM ;FOR SP EXPANSION
$ST SCR,$NXM ;SCRATCH SEGMENTS
.HKILL ST.ZER
IFN ST+NSEGS-., WARN \.-ST,[=WRONG SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END IF2
] ;END IFN PAGING
;GCBMRK GCBCDR GCBCAR GCB ZZZ GCBFOO ZZZ
;;; THE FORMAT OF THE GARBAGE COLLECTOR SEGMENT TABLE IS RATHER HAIRY, SINCE
;;; THE SIZES AND POSITIONS OF ALL FIELDS IN EACH WORD ARE DEPENDENT ON THE
;;; SEGMENT SIZE. THE LOW ORDER <22-<SEGLOG-5>> BITS OF EACH ENTRY CONTAIN
;;; THE HIGH BITS OF THE ADDRESS OF THE BLOCK OF BITS TO BE USED IN MARKING
;;; THAT SEGMENT. (NOTE THAT THE OMITTED LOW-ORDER BITS OF THIS ADDRESS ARE
;;; ZERO ANYWAY.) THESE ADR BITS ARE IN THIS STRANGE RIGHT-ADJUSTED POSITION
;;; FOR THE CONVENIENCE OF THE GCMARK ROUTINE (Q.V.). NOT ALL SEGMENTS HAVE
;;; BIT BLOCKS; THOSE WHICH DO NOT HAVE A BIT BLOCK HAVE ZERO IN THIS FIELD.
;;; TO THE LEFT OF THIS BIT BLOCK ADDRESS FIELD IS A FIELD OF <22-SEGLOG> BITS;
;;; THIS CONTAINS THE NUMBER OF THE NEXT SEGMENT IN THE TABLE OF THE SAME TYPE.
;;; (NOT ALL SEGMENTS ARE LINKED IN THIS WAY; THOSE SEGMENTS WHICH ARE NOT
;;; LINKED TO ANOTHER ONE HAVE THIS FIELD ZERO.) THE HIGH-ORDER BIT (BIT 4.9)
;;; IS ONE IFF GCMARK SHOULD MARK (PERHAPS NOT WITH A BIT BLOCK) THE CONTENTS
;;; OF THE SEGMENT. THE BIT 22 BIT POSITIONS TO THE LEFT OF THE HIGH-ORDER
;;; BIT OF THE BIT BLOCK ADDRESS FIELD IS ONE IFF GCMARK SHOULD MARK FROM THE
;;; CDR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY IF BIT 4.9
;;; IS ONE. THE BIT TO THE RIGHT OF THE CDR BIT IS ONE IFF GCMARK SHOULD ALSO
;;; MARK FROM THE CAR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY
;;; IF THE CDR BIT IS ONE. THESE THREE BITS MUST BE IN THESE EXACT POSITIONS,
;;; AGAIN FOR THE CONVENIENCE OF GCMARK (Q.V.). THE OTHER BITS IN EACH WORD
;;; ARE ARRANGED AS TO USE UP FREE BITS FROM THE LEFT END OF THE WORD, PACKED
;;; IN AROUND THE THREE BITS ALREADY DESCRIBED. THESE BITS INDICATE WHETHER
;;; OR NOT THE SEGMENT CONTAINS VALUE CELLS, SYMBOLS, OR SARS.
GCBMRK==400000 ;THESE ARE ALL LEFT HALF FLAGS
GCBCDR==1←<22-<SEGLOG-5>-1>
GCBCAR==GCBCDR←-1
GCB==1,,525252 ;FOR BIT TYPEOUT MODE
ZZZ==400000
GCBFOO==0
IRPS NAM,X,[VC+SYM+SAR+HNK ]
ZZZ==ZZZ←-1
IFN ZZZ&GCBCDR, ZZZ==ZZZ←-2
GCB!NAM==ZZZ
IFSE X,+, GCBFOO==GCBFOO\ZZZ
TERMIN
IFG GCBHNK-GCBCAR, WARN [GCMARK WILL LOSE ON HUNKS]
;GCST BTB. LXXBSG
GCST: ;GC SEGMENT TABLE
IFE PAGING, BLOCK NSEGS ;FOR PAGING SYSTEM,
; THE GCST TABLE IS SET UP AT RUN TIME BY INIT.
IFN PAGING,[
IF1, BLOCK NSEGS
IF2,[
BTB.==BTBLKS ;LOCATION COUNTER FOR ASSIGNING BIT BLOCKS
$GCST ZER,,,0
IFN LOBITSG, $GCST BIT,,,0
$GCST ST,,,0
$GCST SYS,,,0
$GCST SAR,L,,GCBMRK+GCBSAR
$GCST VC,,,GCBMRK+GCBVC
$GCST XVC,,,0
$GCST IS2,L,,0
$GCST SYM,L,,GCBMRK+GCBSYM
$GCST XXA,L,,0
$GCST XXZ,,,0
$GCST SY2,,,0
$GCST PFX,,,0
$GCST PFS,,,0
$GCST PFL,,,0
$GCST XXP,,,0
$GCST IFS,L,B,GCBMRK+GCBCDR+GCBCAR
$GCST IFX,L,B,GCBMRK
$GCST IFL,L,B,GCBMRK
IFN BIGNUM, $GCST BN,L,B,GCBMRK+GCBCDR
LXXBSG==LXXASG
$GCST1 NXXBSG,XXB,L,,0
IFE LOBITSG, $GCST BIT,,,0
$GCST BPS,,,0
$GCST NXM,,,0
$GCST FXP,,,0
$GCST XFXP,,,0
$GCST FLP,,,0
$GCST XFLP,,,0
$GCST P,,,0
$GCST XP,,,0
$GCST SP,,,0
$GCST XSP,,,0
$GCST SCR,,,0
.HKILL GS.ZER
IFN GCST+NSEGS-., WARN \.-GCST,[=WRONG GC SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)]
] ;END IF2
] ;END OF IFN PAGING
PAGEUP
SPCTOP ST,,[SEGMENT TABLE]
;NNPUSH N0PUSH N0.0PUSH BPURPG $$$NIL EPRNT1 EPRNT2 EPRNT3 ERROR1 EROR1Z EROR1A MSGFCK CMSGFCK
IFN PAGING, SPCBOT SYS
10$ $HISEG
10$ HILOC==. ;ORIGIN OF HIGH SEGMENT
SA$ PSGNAM: 0 ;THESE LOCATIONS FOR SAIL HISEG VALIDATION
SA$ PSGDEV: 0
SA$ PSGEXT: 0
SA$ PSGPPN: 0
SUBTTL BEGINNING OF PURE LISP SYSTEM CODE
PGBOT ERR
;;; THESE CONSTANTS ARE BUILT INTO THE COMPILER.
;;; THEY MUST BE DEFINED HERE FOR THE BENEFIT OF THE PUSHN MACRO.
.SEE PUSHN
NNPUSH==:20 .SEE NPUSH
N0PUSH==:10 .SEE 0PUSH
N0.0PUSH==:10 .SEE 0.0PUSH
BPURPG==:. ;BEGINNING OF PURE PAGES FOR INSERT FILE PAGE AND PURIFY
$$$NIL: 777300,,VNIL ;SYMBOL BLOCK FOR NIL
0,,$$NIL ;ALWAYS KEEP ON FIRST PURE SYSTEM PAGE
;;@ ERROR 130 ERROR MSGS AND HANDLERS
;;; ***** MACLISP ****** MACLISP ERROR HANDLERS, AND MSGS ********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL ERROR UUO HANDLERS
.SEE EPRINT
EPRNT1:
PUSHJ P,SAVX5 ;ERROR PRIN1
PUSH P,AR1 .SEE ERROR3
PUSHJ P,MSGFCK
SKIPN V%PR1
JRST EPRNT2
MOVEI B,(AR1)
CALLF 2,@V%PR1
JRST EPRNT3
EPRNT2: TLO AR1,200000
PUSHJ P,$PRIN1
EPRNT3: STRT 17,[SIXBIT \ !\]
POP P,AR1
JRST RSTX5
ERROR1: MOVEM TT,UUTTSV
MOVEM R,UURSV
EROR1Z: JSP TT,ERROR9 ;PROCESS A LISP ERROR
JRST EROR1A ; (LERR AND LER3)
PUSHJ P,MSGFCK
MOVEI D,-2(P) ;D POINTS TO ERRFRAME
PUSHJ P,ERROR3
EROR1A: MOVEI A,NIL
JRST 2,@[ERRRTN]
;;; MSGFILES CHECK. GET VALUE OF MSGFILES IN AR1 AFTER CHECKING FOR
;;; VALIDITY. IF A LOSER, SIGNAL AN ERROR AFTER RESTORING IT TO (T).
;;; SAVES A.
MSGFCK: HRRZ AR1,VMSGFILES
SFA$ JSP F,MSGFC1 ;MAKE SURE AN SFA NEVER GETS INVOKED FROM
SFA$ 0 ; MPFLOK, BUT STILL DO VALIDITY CHECK
SFA$ MSGFC1:
PUSHJ P,MPFLOK ;SKIPS IF LIST OF FILES *NOT* VALID
CMSGFCK: POPJ P,MSGFCK
PUSH P,A
MOVEI A,(AR1)
PUSHJ P,NCONS
MOVEI B,QMSGFILES
PUSHJ P,XCONS
MOVEI AR1,QTLIST
MOVEM AR1,VMSGFILES
PUSHJ P,[IOL [BAD VALUE FOR MSGFILES!]]
POP P,A
JRST MSGFCK
;ERROR9 LERFRAME EROR9A ERRRTN ERR2 LSPRT0 CLSPRET
SUBTTL ERRFRAME FORMATS
;;; FORMAT OF ERRFRAME:
;;;
;;; [1] NORMAL TYPE ERROR (ERINT, LERR, ETC.)
;;; <SP>,,<RETURN FROM ERROR IF ERINT>
;;; $ERRFRAME
;;; <UUO> ;ADDRESS OF MSG IN RIGHT HALF
;;; <S-EXP> ;FOR ERINT, LER3
;;;
;;; [2] ERRBAD TYPE ERROR (ILL MEM REF, ETC.)
;;; <SP>,,<ADDRESS WHERE ERROR OCCURRED>
;;; $ERRFRAME
;;; 0,,<ADDRESS OF MSG>
.SEE ERRBAD
ERROR9: PUSH P,UUOH
HRLM SP,(P)
PUSH P,[$ERRFRAME] ;RANDOMNUMBER,,EPOPJ
PUSH P,40 ;CANNOT HAVE LH = 0; SEE ERRPRINT
PUSH P,A
LERFRAME==:4 ;LENGTH OF ERRFRAME - WATCH THIS IN CASE OF CHANGE
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
EROR9A: SKIPN PSYMF
SKIPE ERRSW
JRST 1(TT)
JRST (TT)
;;; ERROR RETURN. COME HERE TO PERFORM AN ERROR BREAKOUT (RETURN
;;; TO ERRSET OR TOP LEVEL). VALUE TO RETURN FROM ERRSET IN A.
ERRRTN: SETZM NOQUIT
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
PUSH P,A
SKIPL A,UNREAL
PUSHJ P,CHECKU ;CHECK FOR ANY DELAYED "REAL TIME" INTS
POP P,A
ERR2: SKIPE ERRTN ;TO TOPLEVEL, OR BREAK OUT OF AN ERRSET
JRST ERR0 ;GO BREAK UP AN ERRSET
LSPRT0: PUSH FXP,CATRTN ;RETURN TO TOP LEVEL FROM LISP ERROR
JSP A,ERINI0
POP FXP,CATRTN ;GJS NEEDS TO THROW FROM A *RSET-TRAP
CLSPRET:
SETZ A,LSPRET
SKIPE B,V.TRAP ;INVOKE *RSET-TRAP
CALLF 1,(B)
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JUMPE A,LSPRET
HRRZ T,C2
HRRZ T,1(T)
CAIE T,HACENT ;MEANS BUG ON ERRLIST
JRST LSPRET
MOVE A,VERRLIST
PUSHJ P,NCONS
MOVEI B,QERRLIST
PUSHJ P,XCONS
PUSH P,CLSPRET
FAC [POSSIBLY FELONIOUS ERRLIST - PLEASE INSPECT BEFORE PROCEEDING!]
;ERROR3 EROR3C EROR3E EROR3F
SUBTTL ERINT, SERING, LERR, LER3
;ERROR3: 0 ;PRINT OUT ERROR MESSAGE FOR ORDINARY
; LISP ERRORS (LERR, LER3, ERINT, SERINT)
ERROR3: ;CALLED VIA PUSHJ P,ERROR3
;POINTER TO $ERRFRAME IN D
MOVEI A,TRUTH ;PREVENT AUTO-TERPRI IN THE
JSP T,SPECBIND ; MIDDLE OF AN ERROR MESSAGE
0 A,V%TERPRI ;SPECBIND SAVES D
HRLI AR1,200000 ;OUTPUT FILES LIST FOR MSG IN AR1
LDB TT,[331100,,1(D)] ;P HAS BEEN STACKED UP BY ERROR9
JUMPE TT,EROR3C ;ERRBD2 PUSHS MSG WITH NO LERR OPERATION
HRRZ A,2(D) ;MUST FETCH THE S-EXPRESSION TO PRINT
STRT AR1,[SIXBIT \↑M;!\] ;PRECEDE MSG WITH A ";"
CAIE TT,LERR←-33 ;LERR DOESN'T PRINT AN S-EXP
PUSHJ P,EPRINT
CAIN TT,SERINT←-33 ;SERINT HAS AN S-EXP MSG
JRST EROR3F
LDB A,[270400,,1(D)] ;IF IT IS LERR OR LER3, THEN
CAIE TT,ERINT←-33 ; A NON-ZERO AC FIELD MEANS
JUMPN A,EROR3F ; THE MSG IS AN S-EXP
EROR3C:
STRT AR1,@1(D) ;NOTE: THIS CLOBBERS UUOH LEVEL VARS
EROR3E: STRT AR1,STRTCR
JRST UNBIND
EROR3F:
HRRZ A,1(D)
PUSHJ P,$PRINC
JRST EROR3E
;ERROR5 EROR5F EROR5A EROR6A ERRV
;;; PROCESS ERINT/SERINT CORRECTABLE INTERRUPTS
ERROR5: MOVEM TT,UUTTSV
MOVEM R,UURSV
SKIPN ERRTN ;ALLOW USER INTERRUPT TO RUN,
JRST EROR5F ; EVEN IF INSIDE AN ERRSET,
SKIPN VERRSET ; IF THE ERRSET BREAK IS SET
JRST ERROR1 ;OTHERWISE, JUST DO NORMAL ERROR
EROR5F: LDB TT,[270400,,40]
CAIGE TT,NERINT ;TT HAS AC FIELD FROM UUO
SKIPN VUDF(TT)
JRST ERROR1 ;CONVERT TO LER3 IF NOT ENABLED
MOVEI T,ERRV ;NORMAL XIT FROM CODE BELOW IS POP2J,
CAIE TT,<%IOL←-27>&17 ;IO-LOSSAGE
CAIN TT,<%FAC←-27>&17 ;FAIL-ACT
MOVEI T,EVAL.A
EROR5A: PUSH FXP,T
MOVEI T,(TT) ;SAVE AC NUMBER FOR BELOW
JSP TT,ERROR9 ;PUSH AN ERROR FRAME
JFCL
MOVEI A,(A)
PUSH FXP,T
JSP T,PDLNMK
EXCH D,(FXP)
CAIG D,<%UGT←-27>&17
PUSHJ P,ACONS
PUSH P,A ;FOR GC PROTECTION ONLY
TRO D,2000 ;ERINT SERIES USER INTERRUPT
HRLI D,(A)
MOVE TT,UUTTSV
MOVE T,UUTSV
SKIPN INHIBIT
SKIPE NOQUIT
.VALUE ;STUPID TO SIGNAL ERROR WHEN INTERRUPTS LOCKED
PUSHJ P,UINT
POP FXP,D
SUB P,R70+1 ;GC PROTECTION NO LONGER NEEDED
JUMPE A,EROR6A
PUSH FXP,TT
SKOTT A,LS
JRST EROR6A
POP FXP,TT
HLRZ A,(A) ;IF ATOM RETURNED, THEN CRAP OUT
;OTHERWISE, RETURNED VALUE IS LIST OF
POPJ FXP, ;CORRECT QUANTITY MUST GO TO EVAL.A OR ERRV
EROR6A: MOVE A,(P) ;RESTORE A
MOVEI TT,EROR1Z ;USER DIDN'T SUPPLY SUITABLE VALUE
JRST EROR9A ;SO ERROR OUT
ERRV: SUB P,R70+LERFRAME-1 ;CLEAR OUT ALL BUT RETURN ADDRESS
POPJ P,
;ERRIOJ ERIOJ1 ERIOJ2 ERIOJ3 ERIOJ4 ERIOJ5 ERIOJ8 ERIOJ7 ERIO6B ERIOJ6 ERIO6A ERIOJ9 ERTBL ERFNF% ERIPP% ERPRT% ERFBM% ERAEF% ERISU% ERTRN% ERNSF% ERNEC% ERDNA% ERNSD% ERILU% ERNRM% ERWLK% ERNET% ERPOA% ERBNF% ERCSD% ERDNE% ERSNF% ERSLE% ERLVL% ERNCE% ERSNS% ERFCU% ERLOH% ERNLI% LERTBL
;;; IOJRST UUO DECODER. USAGE:
;;; .CALL FOO ;OR .OPEN, OR WHATEVER
;;; IOJRST N,FOO
;;; IOJRST CAUSES A TRANSFER TO FOO AFTER PUTTING IN C THE
;;; ADDRESS OF A SIXBIT (STRT FORMAT) STRING INDICATING THE
;;; ERROR MESSAGE. THIS MESSAGE MAY BE GIVEN TO AN ERINT
;;; UUO (TYPICALLY %IOL). N IS THE NUMBER OF THINGS ON THE
;;; REGPDL ABOVE THE RETURN ADDRESS - THIS IS A CROCK SO THAT
;;; IOJRST CAN STICK THE ADDRESS OF A RESTORATION ROUTINE
;;; ON THE PDL. (THIS ISN'T DONE IN THE D10 VERSION, HOWEVER.)
;;; FOR ITS, THE MOST RECENT ERROR AS DETERMINED BY .BCHN IS
;;; OBTAINED VIA THE ERR DEVICE AND STACKED UP ON FLP.
;;; FOR D10, TT IS ASSUMED TO CONTAIN THE LOOKUP/ENTER/RENAME
;;; ERROR CODE OF INTEREST, AND IS USED TO INDEX A TABLE.
;;; FOR D20, THE MOST RECENT ERROR IS OBTAINED FROM THE ERSTR
;;; JSYS AND STACKED UP ON FLP.
;;; CLOBBERS THE JCL BUFFER!
;;; USER INTERRUPTS SHOULD BE INHIBITED.
ERRIOJ:
10% PUSH P,A ;SAVE ACS
10% PUSH P,B
IFN D10,[
HRRE C,TT ;ISOLATE ERROR CODE
SKIPL C ;IF TT CONTAINS SOME WEIRD
CAILE TT,LERTBL ; VALUE, JUST CALL IT THE
SKIPA C,ERTBL-1 ; "UNKNOWN ERROR"
MOVE C,ERTBL(C) ;OTHERWISE USE A STANDARD MESSAGE FROM THE TABLE
] ;END OF IFN D10
IFN ITS+D20,[
PUSHN P,2 ;PUSH 2 SPARE PDL SLOTS
LDB A,[270400,,40] ;GET N
ADDI A,2 ;ADD 2 FOR PUSHED ACS
MOVEI C,(P)
ERIOJ1: MOVE B,-2(C) ;SHUFFLE PDL UP TWO SLOTS
MOVEM B,(C)
SUBI C,1
SOJG A,ERIOJ1
MOVEM FLP,-1(C) ;SAVE CURRENT FLP POINTER
MOVEI A,ERIOJ9 ;PLOP IN ADDRESS OF RESTORATION ROUTINE
MOVEM A,(C)
MOVEI C,1(FLP)
PUSH FXP,C
IFN ITS,[
.SUSET [.RBCHN,,A]
.CALL ERIO6B
.LOSE 1400
.CALL ERIOJ6 ;GET MOST RECENT ERROR FOR THIS JOB
.LOSE 1400
MOVE A,[440700,,JCLBF]
MOVEI B,LJCLBF*BYTSWD-1
.CALL ERIO6A ;READ IT IN USING A SIOT
.LOSE 1400
.CLOSE TMPC,
] ;END OF IFN ITS
IFN D20,[
HRROI 1,JCLBF
HRLOI 2,.FHSLF ;GET MOST RECENT ERROR FOR THIS FORK
HRLZI 3,-<LJCLBF*BYTSWD-1>
ERSTR
HALT ;GROSS ERROR
JFCL ;BUFFER NOT BIG ENOUGH
] ;END OF IFN D20
IDPB NIL,A
MOVEI A,'# ;# IS THE STRT QUOTE CHARACTER
PUSH FXP,[440700,,JCLBF]
ERIOJ2: MOVSI B,(440600,,(FLP))
PUSH FLP,R70
ERIOJ3: ILDB C,(FXP) ;GET A CHARACTER OF THE ERROR MESSAGE
CAIGE C,40
JRST ERIOJ8 ;ANY CONTROL CHARACTER TERMINATES IT
CAIGE C,140 ;CONVERT CHARACTER TO SIXBIT,
SUBI C,40 ; ALLOWING LOWER CASE TO WORK
ANDI C,77
CAIE C,'# ;SOME CHARACTERS REQUIRE QUOTING
CAIN C,'↑
JRST ERIOJ5
CAIN C,'!
JRST ERIOJ5
ERIOJ4: IDPB C,B ;DEPOSIT SIXBIT ON FLP
TLNE B,770000
JRST ERIOJ3
JRST ERIOJ2 ;NO MORE ROOM - MUST PUSH ANOTHER WORD
ERIOJ5: IDPB A,B ;DEPOSIT QUOTING CHARACTER
TLNE B,770000
JRST ERIOJ4 ;GO DEPOSIT REAL CHARACTER
MOVSI B,(440600,,(FLP))
PUSH FLP,R70 ;NEED ANOTHER WORD FIRST
JRST ERIOJ4
ERIOJ8: POPI FXP,1 ;FLUSH THE BYTE POINTER ON FXP
POP FXP,C
ERIOJ7: MOVEI A,'! ;MUST WRITE TERMINANTION INTO STRING
IDPB A,B
POP P,B ;RESTORE A AND B
POP P,A
] ;END OF IFN ITS+D20
MOVE T,UUTSV
JRST @40 ;THAT'S 40, NOT UUOH! MUST EFFECT A TRANSFER
IFN ITS,[
ERIO6B: SETZ
SIXBIT/STATUS/
A ;BAD CHANNEL
402000,,A ;STATUS RETURNED
ERIOJ6: SETZ
SIXBIT \OPEN\ ;OPEN FILE
1000,,TMPC ;CHANNEL NUMBER
,,[SIXBIT \ERR\] ;DEVICE NAME
1000,,3 ;3 MEANS ERROR STATUS IN FN2
400000,,A
ERIO6A: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
1000,,TMPC ;CHANNEL NUMBER
,,A ;BYTE POINTER
400000,,B ;BYTE COUNT
] ;END OF IFN ITS
IFN ITS+D20,[
;;; RESTORATION ROUTINE
ERIOJ9: POP P,FLP ;RESTORE FLP
POPJ P, ;NOW REALLY RETRN FROM ORIGINAL FUNCTION
] ;END OF IFN ITS+D20
IFN D10,[
;;; TABLE OF STANDARD LOOKUP/ENTER/RENAME ERRORS
[SIXBIT \UNKNOWN ERROR!\]
ERTBL:
OFFSET -.
ERFNF%:: [SIXBIT \FILE NOT FOUND!\]
ERIPP%:: [SIXBIT \NON-EXISTENT PPN!\]
ERPRT%:: [SIXBIT \PROTECTION VIOLATION!\]
ERFBM%:: [SIXBIT \FILE BUSY BEING MODIFIED!\]
ERAEF%:: [SIXBIT \FILE ALREADY EXISTS!\]
ERISU%:: [SIXBIT \ILLEGAL SEQUENCE OF UUOS!\]
ERTRN%::
SA% [SIXBIT \TRANSMISSION ERROR!\]
SA$ [SIXBIT \DIFFERENT FILENAME SPECIFIED!\]
ERNSF%::
SA% [SIXBIT \NOT A SAVE FILE!\]
SA$ [SIXBIT \THIS ERROR CAN'T HAPPEN!\]
ERNEC%::
SA% [SIXBIT \NOT ENOUGH CORE!\]
SA$ [SIXBIT \BAD RETRIEVAL ##10!\]
ERDNA%::
SA% [SIXBIT \DEVICE NOT AVAILABLE!\]
SA$ [SIXBIT \BAD RETRIEVAL ##11!\]
ERNSD%::
SA% [SIXBIT \NO SUCH DEVICE!\]
SA$ [SIXBIT \DISK IS FULL!\]
IFE SAIL,[
ERILU%:: [SIXBIT \ILLEGAL UUO!\]
ERNRM%:: [SIXBIT \NO ROOM ON FILE STRUCTURE!\]
ERWLK%:: [SIXBIT \DEVICE WRITE-LOCKED!\]
ERNET%:: [SIXBIT \NOT ENOUGH MONITOR TABLE SPACE!\]
ERPOA%:: [SIXBIT \PARTIAL ALLOCATION ONLY!\]
ERBNF%:: [SIXBIT \BLOCK NOT FREE!\]
ERCSD%:: [SIXBIT \CAN'T SUPERSEDE DIRECTORY!\]
ERDNE%:: [SIXBIT \CAN'T DELETE NON-EMPTY DIRECTORY!\]
ERSNF%:: [SIXBIT \SFD NOT FOUND!\]
ERSLE%:: [SIXBIT \SEARCH LIST EMPTY!\]
ERLVL%:: [SIXBIT \SFD NESTED TOO DEEP!\]
ERNCE%:: [SIXBIT \NO-CREATE FOR ALL SEARCH LISTS!\]
ERSNS%:: [SIXBIT \NON-SWAPPED SEGMENT!\]
ERFCU%:: [SIXBIT \CAN'T UPDATE FILE!\]
ERLOH%:: [SIXBIT \SEGMENTS OVERLAP!\]
ERNLI%:: [SIXBIT \NOT LOGGED IN!\]
] ;END OF IFE SAIL
LERTBL==:.
OFFSET 0
] ;END OF IFN D10
;PDLOV PDLH0 PDLOV1 PDLRET PDLH4 PDLLOS PDLMSG
SUBTTL DEC-10 HAIRY PDL OVERFLOW HANDLER (NEWIO)
IFN D10*<PAGING-1>,[
PDLOV: MOVE F,INTPDL ;INTERRUPT ROUTINES MUST LOAD INTPDL INTO F
MOVE R,IPSWD1(F) ;GET OLD INTERRUPT MASK
IFN D10,[
IFE SAIL,[
TRZ R,AP.CLK ;LEAVE ON ALL EXCEPT CLOCK INTS
MOVEM R,IMASK ;REMEMBER, ALLOW PDL OV IN PDL OV HANDLER
APRENB R,
] ;END IFE SAIL
IFN SAIL,[
TLZ R,4 ;TURN OFF <ESC>I INTERRUPTS
MOVEM R,IMASK
INTMSK R ;LEAVE ON ALL BUT ESC<I> AND CLOCK INTS
] ;END IFN SAIL
] ;END IFN D10
HLRZ R,NOQUIT
JUMPN R,GCPDLOV ;PDL OV IN GC - LOSE, LOSE, LOSE!!!
MOVEI R,P ;NOW, AS GLS SAYS, "20 QUESTIONS"
JUMPGE P,PDLH0
MOVEI R,SP
JUMPGE SP,PDLH0
MOVEI R,FLP
JUMPGE FLP,PDLH0
MOVEI R,FXP
JUMPGE FXP,PDLH0
HLRZ R,NOQUIT
SKIPN R
LERR [SIXBIT \RANDOM PDL OVERFLOW!\]
JRST INTXT2
PDLH0: HRRZ D,OC2-P(R) ;GET ORIGION OF OVERFLOW AREA
CAIGE D,@(R) ;IF OVER THEN LOSE
JRST PDLLOS
CAIG D,@(R) ;IF EQUAL THEN WE HAVE REALLY OVERFLOWED
JRST PDLOV1
;IF WE ARRIVE HERE THEN WHAT HAS HAPPENED IS THAT A ROUTINE IS FORCING A
;RECALCULATION OF THE LENGTH OF THE PDL AND THERE DOES NOT ACTUALLY
;EXIST A PDL OV. THEREFORE, ALL WE HAVE TO DO IS TO CALCULATE THE
;NUMBER OF WORDS REMAINING IN THE PDL AND RETURN TO MAINLINE.
HRRZ D,(R) ;GET PDL POINTER
HRRZ F,C2-P(R) ;GET PDL ORIGION
SUBI D,(F) ;COMPUTE NUMBER OF WORDS USED
HLRZ F,C2-P(R) ;GET FULL SIZE OF PDL
ADDI F,(D) ;COMPUTER CURRENT SIZE
HRLM F,(R) ;STORE LENGTH IN PDL POINTER
HRRZ F,INTPDL ;THEN JUST RETURN NORMALLY
JRST INTXT2
;HERE IF WE HAVE A REAL PDL OV BUT STILL HAVE SOME EMERGENCY SPACE TO USE
PDLOV1: MOVE F,OC2-P(R) ;GET OVERFLOW POINTER
MOVEM F,(R) ;STORE IN APPROPRIATE PDL
MOVSI D,QREGPDL-P(R)
HRRI D,1005 ;PDL-OVERFLOW
HRRZ R,INTPDL
HRRZ R,IPSPC(R)
CAIL R,UINT0 ;AVOID DEEP INTERRUPT RECURSION:
CAILE R,EUINT0 ; IF PDL OVERFLOWED WITHIN UINT0,
JRST PDLH4 ; THEN JUST STACK UP THE INTERRUPT,
JSR UISTAK ; AND SOMEONE WILL EVENTUALLY TRY CHECKI
PDLRET: HRRZ F,INTPDL
JRST INTXT2
PDLH4: MOVE R,FXP ;ELSE TRY TO GIVE A PDL OVERFLOW
SKIPE GCFXP ; USER INTERRUPT IMMEDIATELY
MOVE FXP,GCFXP ;REMEMBER, PDL OVERFLOW IS NOT
PUSH FXP,R ; DISABLED INSIDE THE PDL
PUSHJ FXP,$IWAIT ; OVERFLOW HANDLER!!!
JRST XUINT
JRST INTXIT
PDLLOS: MOVE P,C2
MOVE FXP,FXC2
SETZM TTYOFF
STRT UNRECOV
STRT @PDLMSG-P(R)
JRST DIE
PDLMSG: POVPDL ;REG
POVFLP ;FLONUM
POVFXP ;FIXNUM
POVSPDL ;SPEC
] ;END OF IFN D10*<PAGING-1>
;PDLOV5 PDLOV6
SUBTTL UNRECOVERABLE PDL OVERFLOW ACTION
PDLOV5:
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
STRT UNRECOV
STRT (B)
SKIPN ERRTN ;BACK TO TOPLEVEL IF NOT ERRSET
JRST LSPRET
JSP T,GOBRK ;BREAK UP THE ERRSET, AND SEE IF
MOVEI A,NIL
HRRZ TT,OFXC2 ;ENOUGH PDL SPACE WAS RELEASED
HRRZ D,OSC2 ;THEREBY. IF NOT, THEN DO MAJOR
CAILE D,(SP) ;RESTART
CAIG TT,(FXP)
JRST PDLOV6
HRRZ D,OC2
HRRZ TT,OFLC2
CAILE D,(P)
CAIG TT,(FLP)
JRST PDLOV6
JRST (T) ;HERE IS ERRSET'S ERROR EXIT
PDLOV6: SETZM TTYOFF
MOVE P,C2
PUSHJ P,ERRPNU ;UNDO SPECIAL BINDINGS, NO UNWIND-PROTECTS RUN
STRT MESMAJ
JRST LISPGO ;BIG RESTART
;ERRBAD UUOGL1 UUOGL2 UUOGL7 UUOGL8
SUBTTL ILLEGAL OPERATION AND MEMORY VIOLATION HANDLER
ERRBAD: MOVE T,UUTSV
MOVEM D,ERRSVD
SETZM JPCSAV ;TOO LATE TO GET JPC
MOVE D,UUOH
IFN ITS,[
JRST UUOGL2
UUOGL1: MOVEM D,ERRSVD
MOVE D,UUOGLEEP
];END IFN ITS
UUOGL2:
IT$ SUBI D,THIRTY+5 ;SEE IF LOSING INSTRUCTION WAS AN ≠X
IT$ TRNN D,-1
IT$ JRST $XLOST
IT$ ADDI D,THIRTY+5-1 ;ELSE MOVE PC BACK TO LOSING INST
SKIPN VMERR ;SKIP IF USER HANDLER
JRST UUOGL7
PUSH FXP,ERRSVD ;YES, SET UP USER INTERRUPT
PUSH FXP,D
HRLI D,(D)
HRRI D,UIMILO+100000 ;ILLEGAL OPERATION
PUSHJ P,UINT
POP FXP,ERRSVD
POP FXP,D
JRST 2,@ERRSVD ;RESTORE MACHINE FLAGS
UUOGL7: EXCH D,ERRSVD ;NO USER HANDLER
IT$ .CALL UUOGL8 ;CRAP OUT TO DDT
10$ OUTSTR [ASCIZ\?ILLEGAL INSTRUCTION - BAD ERROR\]
.VALUE
IFN ITS,[
UUOGL8: SETZ
SIXBIT \LOSE\ ;TELL DDT WE'RE LOSING
1000,,1+.LZ %PIILO ;ILLEGAL OPERATION
400000,,ERRSVD ;NEW PC
] ;END OF IFN ITS
;UUONVE NTHIEN NTHER LASTER UUOMER UUOFER REMAIR UNOVER OVFLER UNFLER ER2 ER3 ER4 RDNMER ADEAD EG1 INTNCO BADOB
SUBTTL MISCELLANEOUS ERROR ROUTINES
UUONVE: PUSHJ P,NCONS
MOVEI B,QNUMBERP
PUSHJ P,XCONS
FAC [NUMBER FUNCTION RETURNED NON-NUMERIC VALUE!]
JRST UUONVL
NTHIEN: WTA [ILLEGAL ELEMENT NUMBER - NTH/NTHCDR!]
JRST NTHCD5
NTHER: WTA [NOT A PROPER LIST - NTH/NTHCDR!]
JRST NTHCD2
LASTER: WTA [ATOMIC ARG TO LAST!]
JRST LAST
UUOMER: HRRZ A,40
LER3 [SIXBIT \ - MACRO NOT PERMITTED IN UUO CALL!\]
UUOFER: HRRZ A,40
LER3 [SIXBIT \ - WRONG NUMBER OF ARGS SUPPLIED BY UUO CALL!\]
IFN BIGNUM,[
REMAIR: WTA [FLONUM ARG TO REMAINDER!]
JRST -4(T)
] ;END OF IFN BIGNUM
UNOVER:
IFE NARITH, TLNN T,100 .SEE %PCFXU ;FLOATING UNDERFLOW
IFN NARITH, TLNN A,100 .SEE %PCFXU ;FLOATING UNDERFLOW
OVFLER: LERR [SIXBIT \ARITHMETIC OVERFLOW!\]
UNFLER: LERR [SIXBIT \ARITHMETIC UNDERFLOW!\]
ER2: LERR MES3 ;CONTEXT ERROR WITH DOT NOTATION -READ
ER3: LERR [SIXBIT \BLAST? - READ!\]
ER4: LERR [SIXBIT \GO OUT OF CATCH-BREAK DAMN#!!\]
RDNMER: LERR [SIXBIT \NUMERIC OVERFLOW - READ!\]
ADEAD: JFCL ;PUSHJ OR JRST THROUGH DEAD ARRAY PTR
MOVEI A,ARQLS ;COULD ALSO GET HERE VIA ACALL/AJCALL
FAC [ARRAY DEFINITION LOST!]
EG1: UGT [NOT SEEN AS PROG TAG!]
JRST GO2
INTNCO: PUSH P,A ;INTERN CRAP-OUT
MOVEI A,OBARRAY
EXCH A,VOBARRAY
UNLOCKI
PUSHJ P,BADOB
POP P,A
JRST INTRN4
BADOB: FAC [BAD VALUE FOR OBARRAY!]
;DFPER DEFNER REVER PNGE PNGE1 NASER SBADSP CA.DER CA.DE1 CA.DE2 CA.DE3
DFPER: POPI P,1
POP P,A
WTA [WRONG FORMAT - DEFPROP!]
JRST DEFPROP
DEFNER: POPI P,1
POP P,A
WTA [WRONG FORMAT - DEFUN!]
JRST DEFUN
REVER: WTA [NOT A PROPER LIST - REVERSE/NREVERSE/NRECONC/APPEND/NCONC!]
JRST REV4
PNGE:
PNGE1: %WTA NASER
JRST -2(T)
NASER: SIXBIT \ATOMIC SYMBOL REQUIRED!\
SBADSP: SIXBIT \ BAD SPACE TYPE - STATUS!\
;;; INCREDIBLE CROCK TO CONSTRUCT AN ERROR MESSAGE
;;; CONTAINING THE NAME OF THE APPROPRIATE CAR/CDR FUNCTION.
CA.DER: PUSH FXP,[SIXBIT \ILLEGA\]
PUSH FXP,[SIXBIT \L DATU\]
PUSH FXP,[SIXBIT \M - CX\]
PUSH FXP,[SIXBIT \R!!!! \]
CA.DE1: TRNN T,776
JRST CA.DE2
ROT T,-1
JRST CA.DE1
CA.DE2: MOVEI D,-1(FXP)
HRLI D,060600
CA.DE3: ROT T,1
MOVEI TT,'A
TRNE T,1
MOVEI TT,'D
IDPB TT,D
TRNN T,400000
JRST CA.DE3
MOVEI TT,'R
IDPB TT,D
%WTA -3(FXP)
SUB FXP,R70+4
JRST CR1A
;NILSETQ TSETQ XSETQ STORE5 RPLCA0 RPLCD0 RPLCA1 RPLCD1 %ARR0A %ARR0 %ARR0B LDGETQ LDXERR LDALREADY LDATE9 LDATER
NILSETQ: PUSH P,A ;SOME NERD TRIED TO SETQ NIL, MAYBE?
PUSH P,CPOPAJ
CAIE T,VNIL
JRST TSETQ ;NO, 'TWAS REALLY A TSETQ, MAYBE?
MOVEI A,QNILSETQ
%FAC NIHIL
TSETQ: CAIE T,VT
JRST XSETQ ;NO, I DON'T KNOW WHAT IT WAS!
MOVEI A,QTSETQ
%FAC VERITAS
XSETQ: HRLM T,QXSET1 ;HAND VALUE CELL (?) TO LOSER
MOVEI A,QXSETQ
%FAC PURITAS
STORE5: HRRZ A,-1(P)
%WTA [SIXBIT \DIDN'T EVAL TO GOOD ARRAY REFERENCE - STORE!\]
MOVEM A,-1(P)
JRST STORE7
RPLCA0: WTA [BAD ARG - RPLACA!]
JRST RPLACA
RPLCD0: WTA [BAD ARG - RPLACD!]
JRST RPLACD
RPLCA1: WTA [PURE ARG - RPLACA!]
JRST RPLACA
RPLCD1: WTA [PURE ARG - RPLACD!]
JRST RPLACD
%ARR0A: WTA [WRONG TYPE ARRAY - ARRAYCALL!]
JRST %ARR0B
%ARR0: WTA [NOT ARRAY POINTER!]
%ARR0B: MOVEM A,1(D)
JRST %ARR7
LDGETQ: FAC [CAN'T GET DDT SYMBOL - FASLOAD!]
LDXERR: LERR [SIXBIT \BAD VALUE FOR "PURE" - FASLOAD!\]
10$ LDYERR: LERR [SIXBIT \BAD VALUE FOR *PURE - FASLOAD!\]
LDALREADY:
FAC [INCORRECTLY NESTED FASLOAD!]
IFE BIGNUM*DBFLAG*CXFLAG,[
LDATE9: QBIGNUM
QDOUBLE
QCOMPLEX
QDUPLEX
LDATER:
HN% SKIPA A,LDATE9-3(T)
HN$ MOVE A,LDATE9-3(T)
] ;END OF IFE BIGNUM*DBFLAG*CXFLAG
HN% FASHNE: MOVEI A,QHUNK
IFE HNKLOG*BIGNUM*DBFLAG*CXFLAG, LER3 [SIXBIT \IN FASL FILE, BUT NOT IMPLEMENTED IN THIS LISP!\]
.SEE DBCONS
.SEE CXCONS
.SEE DXCONS
IFE DBFLAG*CXFLAG, NUM1MS: SIXBIT \CONS IN COMPILED CODE, BUT NOT IMPLEMENTED IN THIS LISP!\
;IBSERR BASER %LVERR %LNERR
IBSERR: MOVEI A,IN10
EXCH A,VIBASE
PUSHJ P,NCONS
MOVEI B,QIBASE
PUSHJ P,XCONS
PUSH P,[RD0B1]
FAC [BAD VALUE FOR IBASE!]
BASER: MOVEI A,IN10
EXCH A,VBASE
PUSHJ P,NCONS
MOVEI B,QBASE
PUSHJ P,XCONS
PUSH P,[PRINI]
FAC [BAD VALUE FOR BASE!]
IFN USELESS,[
%LVERR: SETZ A,
EXCH A,V%LEVEL
PUSHJ P,NCONS
MOVEI B,Q%LEVEL
PUSHJ P,XCONS
PUSH P,[%LVCHK]
FAC [BAD VALUE FOR PRINLEVEL!]
%LNERR: SETZ A,
EXCH A,V%LENGTH
PUSHJ P,NCONS
MOVEI B,Q%LENGTH
PUSHJ P,XCONS
PUSH P,[%LNCHK]
FAC [BAD VALUE FOR PRINLENGTH!]
] ;END OF IFN USELESS
;NIHIL VERITAS PURITAS POVPDL POVFLP POVFXP POVSPDL MESMAJ UNRECOV FLNMER $ARERR IARERR FXNMER NMV3 CAMMES MES2 MES3 MES5 MES6 MES14 MES18 MES19 MES20 MES21 EMS1 EMS3 EMS5 EMS6 EMS10 EMS12 EMS13 EMS15 EMS16 EMS18 EMS21 EMS22 EMS25 EMS26 EMS29 EMS31 EMS34 STRTCR
SUBTTL A PANDORA'S BOX OF ERROR MESSAGES
NIHIL: SIXBIT \NIHIL EX NIHIL - DON'T SETQ NIL!\
VERITAS: SIXBIT \VERITAS AETERNA - DON'T SETQ T!\
PURITAS: SIXBIT \PURITAS NECESSE EST - DON'T DO RANDOM BINDINGS!\
POVPDL: SIXBIT \REG PDL OVERFLOW!\
POVFLP: SIXBIT \FLONUM PDL OVERFLOW!\
POVFXP: SIXBIT \FIXNUM PDL OVERFLOW!\
POVSPDL: SIXBIT \SPEC PDL OVERFLOW!\
MESMAJ: SIXBIT \↑M;MAJOR RESTART UNDERTAKEN↑M!\
UNRECOV: SIXBIT \↑M;UNRECOVERABLE !\
FLNMER:
$ARERR: SIXBIT \NON-FLONUM VALUE!\
IARERR:
FXNMER: SIXBIT \NON-FIXNUM VALUE!\
DB$ DBNMER: SIXBIT \NON-DOUBLE VALUE!\
CX$ CXNMER: SIXBIT \NON-COMPLEX VALUE!\
DX$ DXNMER: SIXBIT \NON-DUPLEX VALUE!\
NMV3: SIXBIT \NON-NUMERIC VALUE!\
IFN BIGNUM+CXFLAG, NMV5: SIXBIT \UNACCEPTABLE NUMERIC VALUE!\
CAMMES: SIXBIT \FIXNUM CANT COMPARE TO FLONUM. IN =, <, OR >!\
MES2: SIXBIT \ILLEGAL OBJECT SOMEWHERE OR OTHER - READ!\
MES3: SIXBIT \DOT CONTEXT ERROR!\
MES5: SIXBIT \UNDEFINED FUNCTION OBJECT!\
MES6: SIXBIT \UNBOUND VARIABLE!\
MES14: SIXBIT \NOT INSIDE LEXPR/LSUBR!\
MES18: SIXBIT \TOO MANY ARGUMENTS SUPPLIED - APPLY!\
MES19: SIXBIT \TOO FEW ARGUMENTS SUPPLIED - APPLY!\
MES20: SIXBIT \WRONG NUMBER OF ARGS TO LSUBR!\
MES21: SIXBIT \WRONG NUMBER OF ARGS TO FSUBR!\
EMS1: SIXBIT \EXTRA CHARS IN LIST - READLIST!\
EMS3: SIXBIT \NOT ENOUGH CHARS IN LIST - READLIST!\
EMS5: SIXBIT \READ-MACRO CONTEXT ERROR!\
EMS6: SIXBIT \BLAST, MISSING ")"!\
EMS10: SIXBIT \GOT TO TTY INSIDE S-EXP - READ!\
; EMS11: SIXBIT \HOW THE HELL CAN THIS BE?!\ .SEE HHCTB
EMS12: SIXBIT \TOO MANY INTERRUPTS - GO AWAY!\
EMS13: SIXBIT \LOST USER INTERRUPT!\
EMS15: SIXBIT \UNDEFINED FUNCTION IN UUO CALL!\
EMS16: SIXBIT \MORE THAN 5 ARGS!\
EMS18: SIXBIT \FUNCTION UNDEFINED AFTER AUTOLOAD!\
EMS21: SIXBIT \IMPROPER USE OF MACRO - EVAL!\
EMS22: SIXBIT \ILGL GO OR RETURN - NOT INSIDE A PROG!\
EMS25: SIXBIT \UNEVALUABLE DATUM - EVAL!\
EMS26: SIXBIT \FILE NOT FOUND!\
EMS29: SIXBIT \NO CATCH FOR THIS TAG - THROW!\
EMS31: SIXBIT \INVALID ARG TO GENSYM!\
EMS34: SIXBIT \NOT SUBR POINTER!\
STRTCR: SIXBIT \↑M!\
;ERRERC ERRERO ERERER EVAL.A EVAL.1 .UDT .UDT1 .UDT2
SUBTTL YET MORE MISCELLANEOUS ERROR ROUTINES
ERRERC: POP P,A ;LIKE (ERROR MSG ARGS)
LER3 1,@(P)
ERRERO: MOVEI A,(B)
WTA [INVALID ERROR CHANNEL SPECIFICATION!]
JRST ERRERB
ERERER: MOVEI D,Q$ERROR
SOJA T,S2WNAL
EVAL.A: SUB P,[LERFRAME,,LERFRAME] ;CLEAR OUT ALL OF ERRFRAME
PUSHJ P,SAVX5 ;SAVE EVERYTING AND EVAL A
PUSHJ FXP,SAV5M1 ;ORDINARY FAIL-ACT ERROR.
PUSHJ P,EVAL
EVAL.1: PUSHJ FXP,RST5M1
JRST RSTX5
.UDT: SKOTTN A,FX+BN ;COME HERE WHEN COMPILED CODE CANT
JRST .UDT2 ; FIND A TAG FOR A COMPUTED "GO"
SKIPN ERRSW
JRST .UDT1
PUSH P,A
STRT 17,[SIXBIT \↑M;IN !\] ;USE MSGFILES, SINCE UGT BELOW WILL
HRRZ B,-1(P) ;GET RETURN ADDRESS
HRRZ AR1,VMSGFILES
TLO AR1,200000
PUSHJ P,ERRAD1 ;AND PRINT OUT FUN THEREFOR
POP P,A
.UDT1: UGT [ UNDEFINED COMPUTED GO TAG!]
POPJ P,
.UDT2: SETZM PNBUF
SETZM PNBUF+1
SETZM PNBUF+2
MOVEI C,10.
MOVEI R,.UDT4
MOVE AR1,[440700,,PNBUF]
JUMPGE TT,.+3
MOVNS TT
%NEG%
PUSHJ P,PRINI9
SETOM LPNF
MOVEI C,(AR1)
JRST RINTERN
; ENDCODE [.UDT]
;ESB6 WNAERR WNAER1 QF3A QF2A QF1A UUOH3C UUOH3A UUOUER UUOUE1 UUOUE2 EPRINT
ESB6: MOVEI D,0
WNAERR: CAMG TT,T
SKIPA TT,[MES19] ;TOO FEW ARGS
MOVEI TT,MES18 ;TOO MANY ARGS
MOVEM B,QF1SB
PUSH FXP,TT
JUMPN D,WNAER1 ; D ↑= 0 => LISTING ALREADY DONE
PUSH FXP,R
PUSHJ FXP,LISTX
POP FXP,R
WNAER1: HLRZ B,(P)
PUSHJ P,XCONS
MOVEM A,(P)
PUSHJ P,ARGSCU
POP FXP,TT
JRST QF1A
QF3A: SKIPA TT,[MES19] ;AT THIS POINT, WE CRAP OUT
QF2A: MOVEI TT,MES18
MOVE T,R
PUSHJ FXP,LISTX
HLRZ B,(P)
JUMPN B,.+2
MOVEI B,QM ;QUESTION MARK!
PUSHJ P,XCONS
EXCH A,(P)
JSP T,%CADR
QF1A: PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
%WNA (TT)
JRST EVAL
UUOH3C: SAVE A B
MOVEI T,EMS18
JRST UUOUE1
UUOH3A: SAVE A B
UUOUER: MOVEI T,EMS15
UUOUE1: MOVNI A,LUUSV ;UNDEFINED UUO CALL
PUSH FXP,UUOH+LUUSV(A)
AOJL A,.-1
PUSH FXP,40
HRRZ A,40
%UDF (T) ;UNDEF FUN IN UUO CALL (OR AFTER AUTOLOAD)
POP FXP,40
MOVEI T,LUUSV
POP FXP,UUOH-1(T)
SOJG T,.-1
HRRZ T,A
JUMPN A,UUOUE2
HRRZ A,40
PUSHJ P,EPRINT
LERR [SIXBIT \UNDEFINED FUNCTION CALLED!\]
UUOUE2: POP P,B
POP P,A
CAIE T,QUNBOUND
JRST UUOH0A
JRST UUOH3A
EPRINT: SKIPN ERRSW ;ERROR PRINTOUT
POPJ P,
JRST EPRNT1
;EV3B EV3A EV3J IAP2A IAP2J WNAL0 WNALOSE WNAL1 STERR WNAFOSE FASLUR FASLUH FASLNX FASLNC LDFERR
EV3B: SKIPA A,EV0B
EV3A: HLRZ A,AR1
%UDF MES5 ;UNDEFINED FUNCTION OBJECT
JRST EV4B
EV3J: HLRZ A,AR1
%UDF EMS18 ;FN UNDEF AFTER AUTOLOAD
JRST EV4B
IAP2A: TDZA TT,TT ;UNDEFINED FN OBJECT
IAP2J: MOVEI TT,EMS18-MES5 ;FN UNDEF AFTER AUTOLOAD
HLRZ A,(C)
SKIPN A
HRRZ A,(C)
%UDF MES5(TT)
HRRM A,(C)
JRST ILP1
WNAL0: MOVE D,(TT)
TLNE D,1 ;SKIP IF LSUBR
JRST WNAFOSE
WNALOSE:
PUSHJ FXP,LISTX ;LISTIFY UP LSUBR ARGS
MOVEI TT,MES20 ;USE LSUBR MESSAGE
WNAL1: MOVEI B,(D)
PUSHJ P,XCONS ;CONS FUNCTION NAME ONTO ARG LIST
PUSH P,A
MOVEI A,QM ;USE ? FOR ARGS SPEC
JRST QF1A
STERR: MOVEI D,(F)
WNAFOSE: MOVEI TT,MES21 ;USE FSUBR MESSAGE
JRST WNAL1
IFN D10,[
FASLUR: RELEASE TMPC,
FASLUH: UNLOCKI
LERR [SIXBIT \CAN'T DEPURIFY HIGH SEGMENT!\]
] ;END OF IFN D10
FASLNX:
PG% SETZM LDXSIZ
PG$ SETZM LDXLPC
FASLNC:
HRRZ A,LDBSAR
PUSHJ P,$CLOSE
LERR [SIXBIT \YOU HAVE RUN OUT OF CORE - FASLOAD!\] ;TOTAL LOSS
LDFERR:
HRRZ A,LDBSAR
PUSHJ P,$CLOSE
UNLOCKI
MOVE A,LDFNAM
MOVEI B,QFASLOAD
PUSHJ P,XCONS
PUSHJ P,UNBIND
SUB P,R70-LDPRLS+1
FAC [FILE NOT IN FASLOAD FORMAT!]
;LMBERR LXPRLZ DOERRE GETLE GETLE1 SETWNA SIGNPE PROPER RMPER0 LFYER GENSY8 ARGCM8 ARGCM0 ARGCM1 ARGCM2
LMBERR: EXCH A,C
MOVE R,T
WTA [BAD LAMBDA LIST!]
MOVE TT,C
JRST IPLMB1
LXPRLZ: LERR [SIXBIT \TOO MANY ARGS TO LEXPR!\]
DOERRE: MOVEI A,(B)
WTA [ BAD END TEST FORM - DO!]
MOVEI B,(A)
JRST DO4C
GETLE: EXCH A,B
GETLE1: WTA [BAD LIST - GETL!]
EXCH A,B
JRST GETL
SETWNA: POP P,A
MOVEI B,QSETQ
PUSHJ P,XCONS
PUSHJ P,NCONS
WNA [ODD NUMBER OF ARGS - SETQ!]
JRST EVAL
SIGNPE: MOVE A,(P)
WTA [UNRECOGNIZABLE TEST REQUEST - SIGNP!]
MOVEM A,(P)
JRST SIGNP0
PROPER: WTA [BAD ARG - PUTPROP!]
JRST PUTPROP
RMPER0: WTA [BAD ARG - REMPROP!]
JRST REMPROP
LFYER: PUSHJ P,NCONS ;NOT INSIDE LSUBR
MOVEI B,QLISTIFY
PUSHJ P,XCONS ;LET LOSER FIGURE IT OUT
%FAC MES14
GENSY8: %WTA EMS31
PUSH P,A
JRST GENSY7
ARGCM8: WTA [ARG TOO LARGE OR <1 - ARG/SETARG!]
JRST ARGCOM
ARGCM0: MOVEI R,-1(R) ;NOTE: FLUSHES FLAGS IN LEFT HALF!
CAIN R,ARGXX
JRST ARGCM1
CALLF 2,QLIST
MOVEI B,QSETARG
JRST ARGCM2
ARGCM1: PUSHJ P,NCONS
MOVEI B,QARG
ARGCM2: PUSHJ P,ACONS ;LISTIFY AGAIN, WITHOUT LOSING B
PUSHJ P,XCONS
%FAC MES14
;PTRCKE .STOLZ TYOAGE GTRDT9 EOFE EOFE1 MAPWNA MEMQER DLTER LIST.9 SUSPE
PTRCKE: PUSH P,A
MOVEI A,(TT)
%WTA EMS34
MOVEI TT,(A)
POP P,A
JRST PTRCHK
.STOLZ: PUSH P,B
PUSHJ P,NCONS
MOVEI B,QM
PUSHJ P,XCONS
MOVEI B,QSTORE
PUSHJ P,XCONS
POP P,B
PUSH P,T
FAC [CAN'T STORE INTO NON-ARRAY!]
TYOAGE: WTA [NOT ASCII VALUE!]
JRST TYOARG
GTRDT9: FAC [BAD VALUE FOR READTABLE!]
EOFE: MOVEI A,(AR1)
PUSHJ P,NCONS
MOVEI B,QRDEOF
PUSHJ P,XCONS
PUSHJ P,EOFE1
JUMPE A,EOF5
SKIPE T,EOFRTN ;CLOBBER IN EOF VALUE IF NON-NIL
HRRM A,-LERSTP-1(T) ; AND IF EOF FRAME EXISTS
JRST EOF5
EOFE1: FAC [END OF FILE WITHIN READ!]
MAPWNA: MOVEI D,QMAPLIST-MAPLIST-1(TT)
SOJA T,WNALOSE
MEMQER: EXCH A,(P)
WTA [NOT A PROPER LIST - MEMBER/DELETE/ASSOC!]
MOVE B,A
EXCH A,(P)
JRST (T)
DLTER: CAIE D,MEMBER
SKIPA D,[QDELQ]
MOVEI D,QDELETE
JRST WNALOSE
LIST.9: MOVEI D,QLIST. ;ZERO ARGS => ERROR
SOJA D,WNALOSE
SUSPE: PUSHJ P,NCONS
MOVEI B,QSUSPEND
PUSHJ P,XCONS
MOVE TT,FXP ;TO ALLOW RETURNS FROM THE FAC, FXP
SUB TT,R70+1 ; MUST BE RESTORED
SKIPE (FXP)
MOVE TT,(FXP) ;IF TOP OF FXP NON-ZERO THEN IS POINTER
MOVE FXP,TT ; TO OLD FXP; RESTORE CORRECT FXP
FAC [I/O IN PROGRESS - CAN'T SUSPEND!]
;GTPDL1 RAND9 S2WNAL TYPKER S1WNAL GRCTIE FRERR CRSRP2 ALST0 LFY0 ALCK0 PRGER1 DOERR DO5ER
GTPDL1: WTA [ NOT PDL POINTER!]
JRST GTPDLP
RAND9: MOVEI D,QRANDOM
S2WNAL: SOJA T,S1WNAL
TYPKER: MOVEI D,QTYIPEEK
S1WNAL: SOJA T,WNALOSE
GRCTIE: EXCH A,B
WTA [NOT VALID READTABLE INDEX!]
EXCH A,B
JRST GRCTI
FRERR: WTA [NOT A FRAME POINTER - FRETURN!]
JRST FRETURN
IFN USELESS*ITS,[
CRSRP2: WTA [BAD CURSOR CODE - CURSORPOS!]
JRST CRSRP3
] ;END OF IFN USELESS*ITS
ALST0: MOVE A,-1(P)
WTA [BAD ALIST - EVAL/APPLY!]
MOVEM A,-1(P)
JRST ALIST
LFY0: WTA [ARG TOO LARGE - LISTIFY!]
JRST LISTIFY
IFN ITS+SAIL,[
ALCK0: EXCH A,B
WTA [BAD ARG - ALARMCLOCK!]
JRST ALARMCLOCK
] ;END OF IFN ITS+SAIL
PRGER1: EXCH A,AR2A
WTA [BAD VAR LIST - PROG!]
EXCH A,AR2A
JRST PRG1
DOERR: POP P,A
WTA [BAD VAR LIST - DO!]
MOVEM A,-2(P)
JRST DO5
DO5ER: MOVEI A,(B)
WTA [EXTRANEOUS STEPPER - DO!]
JRST DO5Q
;ATAN.7 EXP.ER EXPER1 SIN.ER COS.ER SQR$ER LOG.ER NUMER ARTHER 1EQNF 1GPNF 2EQNF 2GPNF ALHNKE
ATAN.7: LERR [SIXBIT \OVERFLOW/UNDERFLOW IN ATAN!\]
EXP.ER: MOVE D,[EXPER1,,[SIXBIT \ARG TOO BIG - EXP!\]]
JRST NUMER
EXPER1: EXCH A,B
JRST EXP.
SIN.ER: SKIPA D,[SIN.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - SIN!\]]
COS.ER: MOVE D,[COS.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - COS!\]]
JRST NUMER
SQR$ER: SKIPA D,[SQRT.,,[SIXBIT \NEG ARG - SQRT!\]]
LOG.ER: MOVE D,[LOG.,,[SIXBIT \NON-POS ARG - LOG!\]]
NUMER: JSP T,PDLNMK ;IF ARG WAS A PDL NUM, GET A REAL ONE
%WTA (D) ;COMPLAIN TO LOSER
HLRZS D
JRST 2,@D
IARERR
$ARERR
ARTHER: %WTA @.-1(T)
JRST ARITH
1EQNF: TDZA T,T
1GPNF: MOVEI T,$GREAT-$EQUAL
EXCH A,B
%WTA CAMMES
JRST $EQUAL(T)
2EQNF: TDZA T,T
2GPNF: MOVEI T,$GREAT-$EQUAL
%WTA CAMMES
EXCH A,B
JRST $EQUAL(T)
ALHNKE: PUSH P,A
PUSH FXP,TT
MOVEI A,(FXP)
WTA [CAN'T CREATE A HUNK OF THIS SIZE!]
POPI FXP,1
MOVE TT,(A)
POP P,A
JRST ALHUNK
;GCMLOSE GCMES GCLSMS GCLUZ GCLUZ3 GCLUZ5 GCLUZ4 GCLUZ6 GCLUZ7 GCPDLOV DIE
GCMLOSE: HRRZ C,GCMES+NFF(F)
JSR GCRSR
SETOM PANICP
%GCL GCLSMS
SETZM PANICP
POP P,A
SETOM IRMVF ;ON GENERAL PRINCIPLES, GCTWA ONCE
JRST AGC
GCMES: QLIST
QFIXNUM
QFLONUM
DB$ QDOUBLE
CX$ QCOMPLEX
DX$ QDUPLEX
BG$ QBIGNUM
QSYMBOL
IFN HNKLOG,[
RADIX 10.
REPEAT HNKLOG+1, CONC QHUNK,\.RPCNT
RADIX 8
] ;END OF IFN HNKLOG
QARRAY
QSYMBOL ;FOR SYMBOL-BLOCKS, SIMPLY SAY "SYMBOL"
IFN .-GCMES-NTYPES-1+1, WARN [WRONG LENGTH TABLE]
GCLSMS: SIXBIT \STORAGE CAPACITY EXCEEDED!\
;;; COME HERE WHEN THINGS LOOK REALLY DESPERATE IN GC.
GCLUZ: SKIPN PANICP ;HOPE FOR THE BEST, JPG!
SKIPE INHIBIT ;GC-LOSSAGE CAN'T WIN IF INHIBITED
CAIA
JRST GCMLOSE
SKIPE C,F
HRRZ C,GCMES+NFF(F) ;WELL, IT LOOKS LIKE WE
JSR GCRSR ; HAVEN'T EVEN A SNOBOL'S
SETZM TTYOFF ; CHANCE IN HELL HERE...
JUMPE A,GCLUZ6
PUSHJ P,PRINT ;TELL LOSER HE LOST TOTALLY
GCLUZ3: STRT 17,GCLSMS
STRT 17,[SIXBIT \ BEYOND RECUPERATION!\]
SKIPLE IRMVF
JRST GCLUZ7
GCLUZ5: MOVEI TT,SPDLORG
CAILE TT,(SP) ;IF WE LOST OUT GC'ING AT TOP
JRST DIE ; LEVEL, WE ARE TOTALLY LOST
GCLUZ4: STRT 17,MESMAJ ;OTHERWISE WE HAVE HALF A CHANCE
PUSHJ P,ERRPNU ; OF FREEING UP SOME STORAGE (NO UNWIND-PRO'S)
JRST LISPGO ; BY UNBINDING SPECIAL VARIABLES
GCLUZ6: STRT 17,[SIXBIT \SYMBOL BLOCK!\]
JRST GCLUZ3
GCLUZ7: SETOM IRMVF
JRST GCLUZ4
GCPDLOV: SETZM TTYOFF
MOVE P,C2
MOVE FXP,FXC2
STRT 17,[SIXBIT \↑M;PDL OVERFLOW WHILE IN GC#!!\]
JRST GCLUZ5
;;; COME HERE WHEN EVERY HOPE FOR RECOVERY HAS BEEN EXHAUSTED.
DIE: STRT 17,[SIXBIT \↑M;YOU HAVE LOST BADLY#!↑M!\]
.VALUE
JRST DIE
;ERRADR ERRAD1 ERRDCD CPRIN1 ERRO2E ERRO2Q ERRO2A ERRO2C ERRO2H ERRO2G ERRO2B ERRO2R
SUBTTL ERROR ADDRESS DECODER
ERRADR: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
ERRAD1: PUSH P,AR1
PUSHJ P,ERRDCD
POP P,AR1
JRST $PRIN1
ERRDCD: MOVEI A,QM ;DECODE ADDRESS AS SUBR OR ARRAY
10$ CAIL B,ENDFUN ; PROPERTY OF SOME ATOM
10% CAIGE B,BEGFUN ;ADDRESS 0 ALWAYS GIVES OUT QM - SEE BK1A1B
CPRIN1: POPJ P,PRIN1 ;ERRDCD SAVES T (SEE WNAYOSE)
10$ CAIL B,BEGFUN
10% CAIGE B,ENDFUN
JRST ERRO2E
CAIL B,BBPSSG
CAMLE B,BPSH
POPJ P,
ERRO2E:
10$ MOVEI AR2A,BBPSSG
10% MOVEI AR2A,BEGFUN
LOCKI ;GCGEN IS NOT INTERRUPT SAFE
JSP R,GCGEN
ERRO2Q
UNLKPOPJ
ERRO2Q: SKIPE INTFLG ;LET INTERRUPTS HAPPEN - THIS IS A VERY
JRST ERRO2R ; LONG PROCESS FOR LARGE OBARRAYS!
ERRO2A: HLRZ TT,(D)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2B
HLRZ AR1,(TT)
HRRZ TT,(TT)
CAIN AR1,QLSUBR
JRST ERRO2H
CAIE AR1,QSUBR
CAIN AR1,QFSUBR
JRST ERRO2H
CAIE AR1,QARRAY
JRST ERRO2C
HLRZ AR1,(TT)
HRRZ TT,(AR1)
CAML B,@VBPEND ;IF ARG IS < BPEND, THEN CANT BE AN ARRAY
CAIGE TT,-3(B)
JRST ERRO2B
JRST ERRO2G
ERRO2H: HLRZ TT,(TT)
10$ CAIL B,HILOC ;IF ARG IS IN HIGH SEGMENT,
10$ JRST ERRO2G ; MUST BE SUBR
CAML B,@VBPORG
JRST ERRO2B ;IF ARG > BPORG, THEN CANT BE A SUBR [MUST BE ARRAY]
ERRO2G: CAMLE TT,AR2A
CAMLE TT,B
JRST ERRO2B
MOVE AR2A,TT
HLRZ A,(D)
ERRO2B: HRRZ D,(D)
JUMPN D,ERRO2A
JRST GCP8A
ERRO2R: HRRZ AR1,VOBARRAY
MOVEI TT,(F)
SUB TT,TTSAR(AR1)
UNLOCKI ;GIVE A POOR INTERRUPT
LOCKI ; A CHANCE IN LIFE
ADD TT,TTSAR(AR1)
HRRI F,(TT)
JRST ERRO2A
;BEGFUN $ERROR ERRERB ERRERN ERRERD SUBR
SUBTTL ERROR, ERRFRAME, ERRPRINT
BEGFUN==.
$ERROR: JUMPE T,EROR1A ;(ERROR) SIMPLY ACTS LIKE (ERR)
AOJE T,[LERR 1,@(P)] ;(ERROR MSG)
AOJE T,ERRERC
AOJN T,ERERER
POP P,A
ERRERB: MOVEI B,(A)
CAIL A,QUDF
CAIL A,QUDF+NERINT
JRST ERRERN
10$ MOVEI D,(A)
10$ SUBI D,QUDF
.ELSE HRREI D,-QUDF(A)
JRST ERRERD
ERRERN: PUSHJ P,FIXP
JUMPE A,ERRERO
MOVEI D,-5(TT)
JUMPL D,ERRERO
ERRERD: CAIL D,NERINT ;# USER INTERRUPT ERRORS - RANGE FROM 0 TO NERINT-1
JRST ERRERO
MOVEI A,POP1J ;(ERROR MSG ARGS CHNO)
EXCH A,(P)
IORI D,<(SERINT)>←-5
DPB D,[2715←30 -1(P)]
XCT -1(P) ;THIS WINS FOR FAIL-ACT, FOR IT WILL
POPJ P, ; POPJ BY ISELF WITHOUT COMING HERE;
; DITTO FOR IO-LOSSAGE.
SUBR: HRRZ B,(A) ;SUBR 1
JRST ERRDCD
;ERRFRAME EPR6 EPR7 EPR5 EPR1 EPR4 EPR3
;;; ERRFRAME TAKES PDL POINTER, AND RETURNS AN ERROR FRAME.
;;; FORM OF RETURNED VALUE:
;;; (ERR <REGPDL PTR> <ERROR MSG> <SPECPDL PTR>)
;;; WHERE <ERROR MSG> TAKES ONE OF THREE FORMS:
;;; (<MESSAGE>)
;;; (<MESSAGE> <LOSING S-EXP>)
;;; (<MESSAGE> <LOSING S-EXP> <TYPE>)
;;; I.E. IT IS A LIST OF ARGS SUITABLE FOR THE ERROR FUNCTION.
ERRFRAME: JSP R,GTPDLP ;SUBR 1
$ERRFRAME ;MUST APPEAR TWICE
$ERRFRAME
JRST FALSE
POPI D,1
PUSH FXP,D
PUSHJ FXP,SAV5M1
MOVE D,2(D) ;D SHOULD POINT TO JUST BELOW THE FRAME MARKER
PUSH P,R70
LSHC D,-33
LSH R,-40
CAIGE D,ERINT←-33
JRST EPR6
MOVEI A,QUDF(R)
PUSHJ P,ACONS
MOVEM A,(P)
EPR6: HRRZ A,(FXP)
HRRZ A,3(A)
HRRZ B,(P)
PUSHJ P,CONS
MOVEM A,(P)
HRRZ A,(FXP)
HRRZ A,2(A)
CAIN D,ERINT←-33
JRST EPR7
CAIE D,SERINT←-33
SKIPE R
JRST EPR5
EPR7: HRLI A,440600 ;IF MSG IS SIXBIT, MUST CREATE
MOVEM A,CORBP ; AN ATOMIC SYMBOL WHOSE PRINT NAME
MOVEI T,EPR1 ; IS THE MESSAGE
PUSHJ FXP,MKNR6C
PUSHJ P,RINTERN
EPR5: POP P,B
PUSHJ P,CONS
PUSH P,CR5M1PJ
PUSH P,A
POP FXP,D
JRST FRM4
EPR1: ILDB BYTEAC,CORBP
CAIN BYTEAC,'! ;! IS END OF MESSAGE
POPJ P,
CAIN BYTEAC,'↑ ;↑ CONTROLIFIES NEXT CHARACTER
JRST EPR3
CAIN BYTEAC,'# ;# QUOTES NEXT CHAR
ILDB BYTEAC,CORBP
EPR4: ADDI BYTEAC,40
JRST POPJ1
EPR3: ILDB BYTEAC,CORBP ;THIS "CONTROLIFICATION" ALGORITHM
ADDI BYTEAC,40 ; CONVERTS ↑M TO CTRL/M, BUT ALSO ↑4 TO
TRC BYTEAC,100 ; LOWER CASE T, ETC.; HENCE CAN REPRESENT
POPJ P, ; ALL OF ASCII USING ↑ AS AN ESCAPE
;ERRPRINT OFCAN
ERRPRINT: ;LSUBR (1 . 2)
JSP F,PRNARG
[QERRPRINT]
PUSHJ P,OFCAN
JSP R,GTPDLP ;PRINT OUT ERROR MESSAGE STACKED ON
$ERRFRAME ; PDL JUST PRIOR TO POINT SPECIFIED BY ARG
$ERRFRAME ;EXTRA COPY OF $ERRFRAME
JRST FALSE
PUSHJ P,ERROR3
JRST TRUE
;OUTPUT FILE CANONICALIZER. MAKES CONTENTS OF AR1
; INTO AN ORDINARY LIST SUITABLE FOR FEEDING TO STRT.
OFCAN: PUSH P,A ;SAVES T
MOVEI A,(AR1)
SKIPGE AR1
PUSHJ P,ACONS
HRRZ B,V%TYO
TLNN AR1,200000
PUSHJ P,XCONS
MOVEI AR1,(A)
JRST POPAJ
;;@ END OF ERROR 130
;;; ERROR FILE HAS DEFINITION FOR BEGFUN
PGTOP ERR,[ERROR HANDLERS AND MESSAGES]
PGBOT TOP
;;; LISPGO HAS BEEN MOVED SO IT WILL STAY IN CORE WHEN PURE PAGES ARE FLUSHED
;;; AT SUSPEND TIME AS CONTROLLED BY THE SUSFLS FLAG.
;LSPRET LSPRT1 HACENT LISP1 LISP2 LISP2A LISP2B
SUBTTL BASIC TOP LEVEL LOOP
;;; (DEFUN STANDARD-TOP-LEVEL ()
;;; (PROG (↑Q ↑W ↑R EVALHOOK BASE IBASE ...)
;;; ERROR ;ERRORS, UNCAUGHT THROWS, ETC. COME HERE
;;; ↑G ;↑G QUITS COME HERE
;;; (RESET-BOUND-VARIABLES-AND-RESTORE-PDLS)
;;; (SETQ ↑Q NIL)
;;; (SETQ ↑W NIL)
;;; (SETQ EVALHOOK NIL)
;;; (NOINTERRUPT NIL)
;;; (DO-DELAYED-TTY-AND-ALARMCLOCK-INTERRUPTS)
;;; ;RECALL THAT ERRORS DO (SETQ // ERRLIST)
;;; (MAPC (FUNCTION EVAL) //)
;;; (OR (TOP-LEVEL-LINMODE) (TERPRI))
;;; (DO ((PRT '* *))
;;; (NIL) ;DO FOREVER (UNTIL ERROR OR ↑G QUIT)
;;; (SETQ * (COND ((STATUS TOPLEVEL)
;;; (EVAL (STATUS TOPLEVEL)))
;;; (T (READ-EVAL-*-PRINT PRT) ;print
;;; (READ-EVAL-PRINT-*) ;terpri
;;; (READ-*-EVAL-PRINT ;eval
;;; (*-READ-EVAL-PRINT)))))))) ;read
LSPRET: PUSHJ FXP,ERRPOP
MOVE P,C2 ;RETURN TO TOP LEVEL BY ERR, THROW, AND ERRORS
LSPRT1: JSP T,TLVRSS ;RETURN TO TOP BY ↑G
JSP A,ERINIT
SETZ A, ;NEED A NIL IN A FOR CHECKU
PUSHJ P,CHECKU ;CHECK FOR DELAYED "REAL TIME" INTS
MOVEI A,QOEVAL
SKIPE B,VIQUOTIENT ;SHADES OF ERRLIST!!!
CALLF 2,QMAPC
HACENT: PUSH P,FLP .SEE PDLCHK
PUSH P,FXP
PUSH P,SP
PUSH P,LISP1 ;ENTRY FROM LIHAC
HRRZ F,VINFILE ;ONLY PRINT FIRST ASTERISK IF NO INIT FILE
AOSN TOPAST ;IS THIS THE FIRST TIME?
CAIE F,INIIFA
SKIPA ;NOT (INIT-FILE AND FIRST-TIME)
JRST LISP2B
PUSH P,[Q.]
JSP F,LINMDP
PUSHJ P,ITERPRI
JRST LISP2 ;KLUDGE SO AS NOT TO MUNG *
LISP1: PUSH P,LISP1 ;******* BASIC TOP LEVEL LOOP *******
HRRZM A,V. ;THE SYMBOL * GETS AS ITS VALUE THE
PUSH P,A
LISP2: JSP T,TLVRSS ; RESULT OF THE LAST TOP-LEVEL EVAL
POP P,B
SKIPN A,TLF
JRST LISP2A
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
JRST EVAL
LISP2A: MOVEI A,(B)
PUSHJ P,TLPRINT ;PRINT THE LAST OUTPUT FORM
HRRZ TT,-3(P)
HRRZ D,-2(P)
HRRZ R,-1(P)
PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS
PUSHJ P,TLTERPRI ;OUTPUT A TERPRI
LISP2B: PUSHJ P,TLREAD ;READ AN INPUT FORM
JRST TLEVAL ;EVALUATE IT, RETURNING TO LISP1
;STDIFL TLTERPRI TLTERX TLTER1
;;; (DEFUN STANDARD-IFILE ()
;;; (COND ((OR (NULL ↑Q) (EQ INFILE 'T)) TYI)
;;; ('T INFILE)))
STDIFL: HRRZ A,VINFILE
SKIPE TAPRED
CAIN A,TRUTH
HRRZ A,V%TYI
POPJ P,
;;; (DEFUN READ-EVAL-PRINT-* () ;TOP-LEVEL-TERPRI
;;; (AND READ-EVAL-PRINT-*
;;; (FUNCALL READ-EVAL-PRINT-*))
;;; ((LAMBDA (IFILE)
;;; (AND (TTYP IFILE)
;;; (TOP-LEVEL-TERPRI-X (STATUS LINMODE IFILE)
;;; (STATUS TTYCONS IFILE))))
;;; (STANDARD-IFILE)))
;;;
;;; (DEFUN TOP-LEVEL-TERPRI-X (LM OFILE)
;;; (AND OFILE
;;; (COND ((EQ OFILE TYO)
;;; (TERPRI (CONS T (AND ↑R OUTFILES))))
;;; (T (OR LM ↑W (TERPRI OFILE))))))
TLTERPRI:
SKIPE B,VTLTERPRI ;CHECK FOR USERS REDEFINITION
CALLF 0,(B)
PUSHJ P,STDIFL ;GET STANDARD INPUT FILE
MOVE F,TTSAR(A)
TLNN F,TTS.TY
POPJ P,
MOVEI TT,FT.CNS
MOVE AR1,@TTSAR(A)
;TOP-LEVEL-TERPRI-X; TTYCONS IN AR1, FBT.LN IN F
TLTERX: JUMPE AR1,CPOPJ ;EXIT IF NO TTYCONS FILE
CAME AR1,V%TYO
JRST TLTER1
SKIPE AR1,TAPWRT ;IF SAME AS TYO, TERPRI TO
HRRZ AR1,VOUTFILES ; STANDARD OUTPUT FILES
JRST TERP1
TLTER1: TLNN F,FBT.LN ;IF INPUT FILE NOT IN LINMODE,
SKIPE TTYOFF ; AND ↑W IS NOT SET,
POPJ P, ; TERPRI TO JUST THE TTYCONS FILE
TLO AR1,-1
JRST TERP1
;TLREAD TLRED1 TLRED2 SPCFLS
;;; (DEFUN *-READ-EVAL-PRINT () ;TOP-LEVEL-READ
;;; (AND *-READ-EVAL-PRINT
;;; (FUNCALL *-READ-EVAL-PRINT))
;;; (DO ((EOF (LIST 'TLRED1)) (IFILE) (FORM))
;;; (NIL) ;DO UNTIL RETURN
;;; (SETQ IFILE (STANDARD-IFILE IFILE))
;;; (SETQ FORM (COND (READ (FUNCALL READ EOF))
;;; ('T (READ EOF))))
;;; (COND ((NOT (EQ FORM EOF))
;;; (AND (NULL READ)
;;; (ATOM FORM)
;;; (IS-A-SPACE (TYIPEEK))
;;; (TYI))
;;; (RETURN FORM)))
;;; (COND ((NOT (TTYP IFILE)) (TERPRI T))
;;; ('T (TOP-LEVEL-TERPRI-X () (STATUS TTYCONS IFILE))))))
TLREAD: SKIPE B,VTLREAD ;CHECK FOR USERS REDEFINITION
CALLF 0,(B)
PUSHJ P,STDIFL ;GET STANDARD INPUT FILE AS OF
PUSH P,A ; *BEFORE* THE READ, AND SAVE IT
REPEAT 2, PUSH P,[TLRED1] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1 ;READ THE FORM (POSSIBLY USING USER'S READ)
TLRED1: POP P,B
CAIE A,TLRED1
JRST SPCFLS
MOVE TT,TTSAR(B) ;SIMPLY TERPRI ON EOF IF APPROPRIATE
TLNE TT,TTS.TY
JRST TLRED2
SETZ AR1,
PUSHJ P,TERP1
JRST TLREAD
TLRED2: HRRI TT,FT.CNS
MOVEI AR1,NIL
MOVE AR1,@TTSAR(B)
SETZ F,
PUSHJ P,TLTERX
JRST TLREAD
SPCFLS: SKIPE VOREAD
POPJ P,
PUSH P,A
PUSHJ P,ATOM
JUMPE A,POPAJ
MOVEI T,0 ;PEEL OFF A SPACE, IF THAT
PUSHJ P,TYIPEEK+1 ;WAS WHAT TERMINATED THE ATOM
MOVE T,VREADTABLE
MOVE TT,@TTSAR(T)
MOVEI T,0
TLNE TT,100000 ;WORTHLESS CHAR, OR SPACE ETC.
PUSHJ P,%TYI
JRST POPAJ
;TLEVAL CEVAL NILBAD CSETZ PDLCHK PDLCRP
;;; (DEFUN READ-*-EVAL-PRINT (FORM) ;TOP-LEVEL-EVAL
;;; (AND READ-*-EVAL-PRINT
;;; (FUNCALL READ-*-EVAL-PRINT FORM))
;;; (SETQ - FORM)
;;; ((LAMBDA (+)
;;; (PROG2 NIL
;;; (EVAL +)
;;; (AND (OR (CAR NIL) (CDR NIL))
;;; (ERROR '|NIL CLOBBERED|
;;; (PROG2 NIL
;;; (CONS (CAR NIL) (CDR NIL))
;;; (RPLACA NIL NIL)
;;; (RPLACD NIL NIL))
;;; 'FAIL-ACT))))
;;; (PROG2 NIL + (SETQ + -))))
TLEVAL: SKIPE B,VTLEVAL ;IF USER FUNCTIONS
CALLF 1,(B) ;CALL IT AND EVAL RESULTS
MOVEM A,VIDIFFERENCE ;THE SYMBOL - GETS THE TYPED-IN
MOVEI B,(A) ; EXPRESSION AS ITS VALUE AND KEEPS IT
EXCH B,VIPLUS ;THE SYMBOL + GETS THE THE TYPED-IN
JSP T,SPECBIND ; EXPRESSION AS ITS VALUE, BUT NOT
0 B,VIPLUS ; UNTIL AFTER IT HAS BEEN EVALUATED.
CEVAL: PUSHJ P,EVAL ;SPECBINDING IT ENSURES THAT IT WILL
JUMPE UNBIND ; GET THIS VALUE IN SPITE OF ERRORS.
PUSH P,CUNBIND
NILBAD: PUSH P,A ;FOO! WELL, ERROR HANDLING SAVES
PUSH P,CPOPAJ ;ALL ACS IN CASE YOU WANT TO CONTINUE
MOVS A,NIL
CSETZ: SETZ NIL, ;NIL=0! CAN USE THIS AS A CONSTANT WORD
PUSHJ P,ACONS
%FAC [SIXBIT \NIL CLOBBERED!\]
;;; PUSHJ HERE WITH PROPER VALUES FOR THE RIGHT HALVES
;;; OF <FLP, FXP, SP> IN <TT, D, R>. WILL ERROR OUT
;;; IF THEY DON'T MATCH UP. USED FOR TRAPPING GROSS
;;; ERRORS IN THE SYSTEM.
PDLCHK: SETZ T,
CAIE TT,(FLP)
MOVEI T,QFLPDL
CAIE D,(FXP)
MOVEI T,QFXPDL
CAIE R,(SP)
MOVEI T,QSPECPDL
JUMPE T,CPOPJ ;EVERYBODY HAPPY?
PDLCRP: MOVEI A,(T) ;NO, PDL CRAP-OUT
LER3 [SIXBIT \OUT OF PHASE (SYSTEM ERROR)!\]
;LINMDP TLPRINT TLPR1 IPRIN1
;;; (DEFUN TOP-LEVEL-LINMODE ()
;;; ((LAMBDA (FL)
;;; (COND ((AND (TTYP FL) (STATUS LINMODE FL))
;;; FL)))
;;; (STANDARD-IFILE INFILE)))
;;; SKIP IF INPUT FILE (PASSED IN ACC B) IS IN LINE MODE.
;;; ALSO LEAVE OUTFILES IN AR1 AND READTABLE IN AR2A.
;;; FURTHERMORE LEAVE INPUT FILE IN C (SEE TLPRINT).
;;; ALSO LEAVE TTSAR OF INPUT FILE IN T.
LINMDP: JSP T,GTRDTB
HRRZ C,VINFILE
SKIPE TAPRED
CAIN C,TRUTH
HRRZ C,V%TYI
SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
SFA$ HRLZI TT,AS.SFA ;SFAS ARE NEVER IN LINE MODE
SFA$ TDNE TT,ASAR(C)
SFA$ JRST (F) ;RETURN NON-LINEMODE
MOVEI TT,F.MODE
MOVE T,@TTSAR(C)
TLNN T,FBT.LN ;ONLY A TTY CAN HAVE LINMODE SET
JRST (F) ;TYPICALLY RETURN TO AN ITERPRI
JRST 1(F) ; OR SKIP OVER IT
;;; (DEFUN READ-EVAL-*-PRINT (OBJ) ;TOP-LEVEL-PRINT
;;; (AND READ-EVAL-*-PRINT
;;; (FUNCALL READ-EVAL-*-PRINT OBJ))
;;; ((LAMBDA (FL)
;;; (COND ((OR (NULL FL) (NOT (EQ (STATUS TTYCONS FL) TYO)))
;;; (TERPRI IFILE)))
;;; (COND (PRIN1 (FUNCALL PRIN1 OBJ)) ('T (PRIN1 OBJ)))
;;; (TYO 32.)) ;<SPACE>
;;; (TOP-LEVEL-LINMODE)))
TLPRINT:
SKIPE C,VTLPRINT ;IF USER SPECIFIED FUNCTION
CALLF 1,(C) ;THEN INVOKE IT AND PRINT WHAT IT RETURNS
PUSH P,A ;TOP-LEVEL PRINT
JSP F,LINMDP ;LEAVES INPUT FILE IN C
JRST TLPR1
MOVE T,TTSAR(C) ;PICK UP THE TTSAR
MOVEI TT,FT.CNS
HRRZ C,@T ;PICK UP FT.CNS
TLNE T,TTS.TY
CAME C,V%TYO
TLPR1: PUSHJ P,ITERPRI
MOVE A,(P)
PUSHJ P,IPRIN1
MOVEI A,40
PUSHJ P,TYO
JRST POPAJ
IPRIN1: SKIPN V%PR1
JRST PRIN1
JCALLF 1,@V%PR1
;TLVRSS TLVRS1 SIXJBN
;;; TOP LEVEL VARIABLE SETTINGS
TLVRSS: MOVE A,[PNBUF,,PNBUF+1]
SETZM PNBUF
BLT A,PNBUF+LPNBUF-1
TLVRS1: PUSH P,EOFRTN
MOVE A,[ERRTN,,ERRTN+1]
SETZM ERRTN
BLT A,ERRTN+LEP1-1
SETOM ERRSW
POP P,EOFRTN
SETZB NIL,PANICP
SETZB A,PSYMF
SETZB B,EXPL5
SETZB C,PA3
SETZB AR1,RDLARG
SETZB AR2A,QF1SB
SETZM ARGLOC
SETZM ARGNUM
JRST (T)
IFN D10,[
SIXJBN: PJOB TT,
IDIVI TT,100.
IDIVI D,10.
LSH TT,14
LSH D,6
ADDI TT,(D)
ADDI TT,202020(R)
HRLI TT,(SIXBIT /LSP/)
MOVSM TT,D10NAM ;SAVE ###LSP AS TEMP FILE NAME
POPJ P,
] ;END OF IFN D10
;ERINIT ERINIX ERINI8 ERIN8G ERINI0
SUBTTL INITIALIZATION ON ↑G QUIT AND ERRORS
;;; ERINIT RESETS PDL POINTERS, THEN FALLS INTO ERINI0.
;;; ERINI0 RESETS VARIOUS VARIABLES AND PERFORMS CLEANUP.
ERINIT:
;DISABLE INTERRUPT SYSTEM
10$ SA% MOVE P,C2
10$ SA% MOVE FXP,FXC2
PIPAUSE ;DISABLE ALL INTERRUPTS
ERINIX: ;ENTER HERE IF INTERRUPTS ALREADY DISABLED
IFE PAGING,[
MOVE P,C2 ;SET UP PDL POINTERS
MOVE FXP,FXC2
MOVE FLP,FLC2
MOVE SP,SC2
] ;END OF IFE PAGING
IFN PAGING,[
IT$ MOVE T,PDLFL1 ;CONTAINS <- # OF PDL PAGES,,# OF 1ST PDL PAGE>
IT$ .CALL PDLFLS ;FLUSH ALL PDL PAGES
IT$ .VALUE
20$ WARN [SHOULD TWENEX FLUSH PDL PAGES??]
MOVE T,[$NXM,,QRANDOM]
MOVE TT,PDLFL2 ;CONTAINS <- # OF PDL SEGS,,# OF 1ST PDL SEG>
MOVEM T,ST(TT) ;UPDATE SEGMENT TABLE TO REFLECT
AOBJN TT,.-1 ; LOSS OF PDL PAGES
HRRZ T,PDLFL1
ROT T,-4
ADDI T,(T)
ROT T,-1
TLC T,770000
ADD T,[450200,,PURTBL]
SETZ D,
HLRE TT,PDLFL1
ERINI8: TLNN T,730000
TLZ T,770000
IDPB D,T
AOJL TT,ERINI8
IRP Z,,[P,FLP,FXP,SP]
MOVEI F,Z
MOVE Z,C2-P+Z ;CAUSE ONE PDL PAGE
MOVEI D,1(Z) ; FOR Z TO EXIST
ANDI D,PAGMSK
JSR PDLSTH .SEE PDLST0
TERMIN
ERIN8G: MOVE T,[XPDL,,ZPDL]
BLT T,ZSPDL
] ;END OF IFN PAGING
ERINI0: SETZB NIL,TAPRED ;INITIALIZATION AFTER PDL SETUP
SETZM NOQUIT
SETZM FASLP
IFN USELESS, SETZM TYOSW
SETZM INTFLG
SETZM INTAR
SETZM VEVALHOOK
SETZM GCFXP ;NON-ZERO WOULD MEAN INSIDE GC
SETZM BFPRDP
MOVE T,[-LINTPDL,,INTPDL]
MOVEM T,INTPDL
MOVEI T,$DEVICE ;RESTORE READER'S LITTLE MEN
MOVEM T,TYIMAN
MOVEI T,UNTYI
MOVEM T,UNTYIMAN
;FALLS THROUGH
;ERINI2 ERINI5 ERIN5C ERIN5D ERIN5A ERIN5B ERINI6 ERIN6A ERINI3 SARTOB SATOB1 SATOB7 LPROGZ PDLFLS
;FALLS IN
ERINI2: SKIPL MUNGP ;MAYBE NEED TO UNMUNG SYMBOLS AND SARS
JRST ERINI6
MOVE D,SYSGLK
ERINI5: JUMPE D,ERIN5A
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ
LDB D,[SEGBYT,,GCST(D)]
ERIN5C: MOVSI R,1
ANDCAB R,(F) ;UNMUNGS THE SYMBOL HEADER, IF NECESSARY
HLRZS R
HRRZ R,(R) ;GET ADDR OF VALUE CELL
CAIL R,BVCSG
CAIL R,BVCSG+<NXVCSG+1>*SEGSIZ
JRST .+2
JRST ERIN5D
CAIL R,BPURFS
CAIL R,PFSLAST
JRST .+2
JRST ERIN5D
HRRZS (R) ;UNMUNGS THE VALUE CELL, IF STORED IN LIST SPACE
ERIN5D: AOBJN F,ERIN5C
JRST ERINI5
ERIN5A: MOVE F,[SARTOB,,B]
BLT F,LPROGZ
MOVE D,SASGLK
ERIN5B: JUMPE D,ERINI6
MOVEI F,(D)
LSH F,SEGLOG
HRLI F,-SEGSIZ/2
LDB D,[SEGBYT,,GCST(D)]
JRST SATOB1
ERINI6: HRRZS MUNGP
SKIPN MUNGP ;UNMUNG VALUE CELLS (SEE ALIST)
JRST ERIN6A
MOVEI F,BVCSG
SUB F,EFVCS
HRLI F,(F)
HRRI F,BVCSG
HRRZS (F)
AOBJN F,.-1
SETZM MUNGP
ERIN6A: MOVE B,[ERRTN,,ERRTN+1]
SETZM ERRTN
BLT B,UIRTN
SETOM ERRSW
MOVSI B,-NSFC
ERINI3: MOVE C,SFXTBI(B) ;RESTORE CLOBBERED LOCATIONS
MOVEM C,@SFXTBL(B)
AOBJN B,ERINI3
TLZ A,-1
;ENABLE THE INTERRUPT SYSTEM
IFN ITS,[
.SUSET [.SMASK,,IMASK] ;RESTORE INTERRUPT ENABLE MASKS
.SUSET [.SMSK2,,IMASK2]
.SUSET [.SDF1,,R70] ;RESET DEFER WORDS
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
PIONAGAIN
JRST (A) ;RETURN TO CALLER
SARTOB: ;TURN OFF MARK BITS IN SARS
OFFSET B-.
SATOB1: ANDCAM SATOB7,TTSAR(F)
AOBJP F,ERIN5B
AOJA F,SATOB1
SATOB7:
TTS<GC>,,
LPROGZ==.-1
OFFSET 0
.HKILL SATOB1 SATOB7
PDLFLS: SETZ
SIXBIT \CORBLK\
1000,,0 ;DELETE PAGES...
1000,,-1 ; FROM MYSELF...
SETZ T ; AND HERE'S HOW MANY AND WHERE!
;SPECBIND SPEC1 SPEC2 SPEC6 SPEC5 SPEC4 SPEC3
SUBTTL SPECIAL VARIABLE BINDING AND UNBINDING ROUTINES
JFCL ;HISTORICAL LOSS -- EVENTUALLY FLUSH
SPECBIND: MOVEM SP,SPSV ;0 0,FOO MEANS FOO IS ADDR OF SVC TO BE BOUND TO NIL, SAVES D
SPEC1: LDB R,[271500,,(T)] ;0 N,FOO MEANS SVC FOO TO BE BOUND TO CONTENTS OF ACC N
JUMPE R,SPEC4
CAILE R,17 ;7←41 M,FOO MEANS BIND FOO TO -M(P)
JRST SPEC3 ;OTHERWISE, IS PDP10 INSTRUCTION, SO EXIT
SPEC2: HRRZ R,(R) ;NOTE WELL! NCOMPLR DEPENDS ON THE FACT
CAML R,NPDLL ; THAT R = TT+2 = NUMVALAC+2
CAMLE R,NPDLH
JRST SPEC4
PUSH FXP,T
MOVEI T,(R)
LSH T,-SEGLOG
SKIPL T,ST(T) ;NMK1 WILL WANT TYPE BITS IN T
TLNN T,$PDLNM ;SKIP IF PDL NUMBER
JRST SPEC5
HRR T,(FXP)
LDB R,[271500,,(T)] ;RECOMPUTE ADDRESS OF FROB
CAIG R,17
JRST SPEC6
TRC R,16000#-1
ADDI R,1(P)
SPEC6: PUSHJ P,ABIND3 ;TEMPORARILY CLOSE THE BIND BLOCK
PUSH P,A
HRRZ A,(R)
PUSHJ P,NMK1
MOVEM A,(R) ;CLOBBER LOC OF FROB WITH NEW NUMBER
CAIN R,A ;GRUMBLE
MOVEM A,(P)
SUB SP,R70+1 ;SO RE-OPEN THE BIND-BLOCK
MOVEI R,(A) ;THEREBY INHIBITING INTERRUPTS
POP P,A
SPEC5: POP FXP,T
SPEC4: EXCH R,@(T)
HRL R,(T)
PUSH SP,R
AOJA T,SPEC1
SPEC3: CAIGE R,16000
JRST SPECX
TRC R,16000#-1 ;RH OF R NOW HAS N
ADDI R,1(P) ;SPECBINDING OFF PDL
JRST SPEC2
;ERRPOP ERRPNU UBD0 UBD UBD3 UBD1 UBD4 UNBIND UNBND0 UNBND1
ERRPOP: POP FXP,ERRPAD ;POP RETURN ADR OFF FXP
MOVE TT,C2 ;RUN ALL OF THE UNWIND HANDLERS
MOVEM T,ERRPST ;SAVE T
PUSHJ FXP,UNWPRO
MOVE T,ERRPST ;RESTORE SAVED T
PUSH P,ERRPAD ;SAVE ERR RETURN ADR
;ENTRY POINT IF NO UNWIND-PROTECT FUNCTIONS SHOULD BE RUN
ERRPNU: SKIPA TT,ZSC2 ;TOTALLY POP OFF SPECPDL FOR ERRORS
UBD0: TLZA TT,-1 ;POP SPECPDL TO PLACE SPECIFIED IN TT
SETOM (TT) ;ERRPOP MUST SETOM - SEE UBD4
UBD: CAIL TT,(SP) ;RESTORE THE SPDL BY RESTORING VALUES
JRST UNBND2 ; UNTIL (SP) MATCHES (TT)
POP SP,R
HLRZ D,R
TLZ R,-1
CAMGE R,ZSC2
JRST UBD3
CAIG R,(SP)
JRST UBD4
SKIPN D
.LOSE ;SOMEBODY SCREWED THE SPECPDL - HELP!!!
UBD3: HRRZM R,(D)
UBD1: JRST UBD
UBD4: HLRZ D,(SP)
JUMPN D,UBD ;AMONG OTHER THINGS, ERRPOP'S SETOM MAKES THIS JUMP
PUSH FXP,T ;MUST SAVE T
MOVEI T,(R)
PUSHJ P,AUNBN0 ;FOUND A FUNARG BINDING BLOCK
POP FXP,T ; - USE SPECIAL ROUTINE TO UNBIND IT
JRST UBD
UNBIND: POP SP,T
MOVEM TT,UNBND3 ;HORRIBLE HACK TO SAVE AC TT. THINK ABOUT THIS SOME DAY
UNBND0: TLZ T,-1 ;AUNBIND ENTERS HERE
UNBND1: CAIN T,(SP)
JRST UNBND2
POP SP,TT
MOVSS TT
HLRZM TT,(TT)
JRST UNBND1
;BIND BIND4 STQPUR BIND5 CBIND4 BIND1 POPBJ CPOPBJ MAKVC MAKVC0 MAKVC1 MAKVCX MAKVC3
;;; BIND, AND MAKE-VALUE-CELL ROUTINES.
;;; PUSHJ P,BIND WITH SYMBOL IN A, VALUE IN AR1.
;;; USES ONLY A, TT; MUST SAVE T
;;; JSP TT,MAKVC WITH AN ATOMIC SYMBOL ON THE PDL (WHICH IS POPPED)
;;; AND THE VALUE IN B. RETURNS ADDRESS OF NEW VALUE CELL IN A.
;;; (LATTER CROCK FOR BIND1 ONLY). USES ONLY A,B,TT.
BIND: SKIPN TT,A
JRST BIND5
HLRZ A,(A)
XCTPRO
HRRZ A,(A)
NOPRO
CAIN A,SUNBOUND
JRST BIND1
BIND4: PUSH SP,(A)
HRLM A,(SP)
STQPUR: HRRZM AR1,(A)
POPJ P,
BIND5: MOVEI A,VNIL ;ALLOW PURPGI TRAP TO WORK JUST
CBIND4: JRST BIND4 ;LIKE FOR SETQING T
BIND1: PUSH P,CBIND4 ;SET UP FOR CALL TO MAKVC
PUSH P,B
PUSH P,TT
MOVEI B,QUNBOUND
JSP TT,MAKVC
POPBJ: POP P,B
CPOPBJ: POPJ P,POPBJ
MAKVC: PUSH FXP,TT ;SAVE RETURN ADDR
SPECPRO INTZAX
MAKVC0: SKIPN A,FFVC
JRST MAKVC3
EXCH B,@FFVC
XCTPRO
HRRZM B,FFVC
NOPRO
MAKVC1: HLRZ B,@(P) ;POINTER TO SYMBOL HEADER IS ON STACK
PURTRAP MAKVC9,B, HRRM A,(B)
MAKVCX: SUB P,R70+1 ;POP POINTER, RETURN ADDRESS OF VALUE CELL
POPJ FXP, ; IN A, ADDR OF SY2 BLOCK IN B
IFE PAGING,[
MAKVC3: PUSHJ P,CONS1
SETOM ETVCFLSP
JRST MAKVC1
] ;END OF IFE PAGING
;C1CONS %NCONS NCONS ACONS BGNMAK BNCONS
SUBTTL VARIOUS ODDBALL CONSERS
IFN BIGNUM,[
C1CONS: EXCH T,YAGDBT
JSP T,FWCONS
EXCH T,YAGDBT
JRST ACONS
] ;END OF IFN BIGNUM
%NCONS: PUSH P,T
NCONS: TLZ A,-1
BAKPRO
ACONS: SKIPN FFS ;THIS IS A CONS LIKE XCONS
PUSHJ P,AGC ;BUT USES ONLY ACCUMULATOR A
MOVSS A ;SWAP HALVES OF A, THEN
SPECPRO INTACX
EXCH A,@FFS ;CONS WHOLE WORD FROM A
XCTPRO
EXCH A,FFS
NOPRO
POPJ P,
IFN BIGNUM,[
BAKPRO
BGNMAK: ;MAKE A POSITIVE BIGNUM (SAME AS BNCONS)
BNCONS: SKIPN FFB ;BIGNUM CONSER
PUSHJ P,AGC
EXCH A,@FFB
XCTPRO
EXCH A,FFB
NOPRO
POPJ P,
] ;END OF IFN BIGNUM
;SIXMAK SIXMK1 .UDT4 SIXATM SIXAT1 PNBFAT PNBFA1 PNBFMK PNBFM6
;;; EXPLODEC ARGUMENT IN A (WITH BASE=10., *NOPOINT=T),
;;; AND RETURN A SIXBIT WORD IN TT. CLOBBERS ALL ACS.
SIXMAK: MOVEI B,IN0+10.
JSP T,SPECBIND
0 B,VBASE
0 B,V.NOPOINT
MOVSI TT,(SIXBIT \@\)
MOVEM TT,SIXMK2
MOVE AR1,[440600,,SIXMK2]
HRROI R,SIXMK1 .SEE PR.PRC
PUSHJ P,PRINTA ;CALL PRINTA TO EXPLODEC THE ARGUMENT
MOVE TT,SIXMK2
JRST UNBIND
SIXMK1: CAIGE A,140 ;THIS SAYS CONVERT LOWER CASE TO UPPER
TRC A,40 ;CONVERT CHAR TO SIXBIT
TLNE AR1,770000
.UDT4: IDPB A,AR1 ;MAYBE SAVE IT, UNLESS ALREADY HAVE SIX
POPJ P,
;;; TAKE SIXBIT IN TT, RETURN AN ATOMIC SYMBOL IN A.
;;; EMBEDDED BLANKS COUNT, BUT TRALING ONES DON'T.
;;; A ZERO WORD BECOMES THE ATOM "*". SAVES F.
SIXATM: SETOM LPNF
MOVE C,PNBP
MOVSI T,(ASCII \*\)
MOVEM T,PNBUF
SETZM PNBUF+1
SIXAT1: JUMPE TT,RINTERN ;RINTERN SAVES F
SETZ T,
LSHC T,6
ADDI T,40 ;CONVERT SIXBIT TO ASCII
IDPB T,C ;STICK CHARACTERS IN PNBUF
JRST SIXAT1
;;; A STRING IS IN PNBUF, TERMINATED BY A NULL.
;;; LOCATE ITS END, AND CALL RINTERN TO MAKE AN ATOM.
PNBFAT: MOVE T,PNBP
PNBFA1: MOVE C,T
ILDB TT,T
JUMPN TT,PNBFA1
SETOM LPNF
JRST RINTERN
;;; TAKE AN S-EXPRESSION IN A, AND EXPLODEC IT INTO PNBUF.
;;; AR2A WILL CONTAIN THE COUNT OF UNUSED CHARACTER POSITIONS IN PNBUF.
;;; PRESERVES ITS ARGUMENT.
PNBFMK: PUSH P,A
PUSH P,CPOPAJ
SETZM PNBUF
MOVE T,[PNBUF,,PNBUF+1]
BLT T,PNBUF+LPNBUF-1
MOVE AR1,PNBP
MOVEI AR2A,LPNBUF*BYTSWD
HRROI R,PNBFM6 .SEE PR.PRC
JRST PRINTA
PNBFM6: JUMPLE AR2A,CPOPJ ;GIVE UP IF NO MORE ROOM IN PNBUF
IDPB A,AR1 ;ELSE STICK CHARACTER IN
SOJA AR2A,CPOPJ
;PPNATM PPNAT2 PPNAT4 PPNAT6 PPNAT3 PPNAT5
IFN D10,[
;;; CONVERT A PPN IN TT TO AN "ATOM", I.E. AN S-EXPR OF APPROPRIATE FORM. SAVES F.
PPNATM:
IFN CMU,[
HLRZ T,TT
CAIG T,10 ;PPN'S WITH PROJECT BETWEEN 1 AND 10
JRST PPNAT2 ; MUST BE EXPRESSED IN DEC FORM
MOVE T,[TT,,PNBUF]
SETZM PNBUF+1 ;NEED THIS BECAUSE OF CMU BUG
DECCMU T, ;TRY CONVERTING PPN TO CMU STRING
JRST PPNAT2 ;ON FAILURE, JUST REVERT TO DEC FORMAT
JRST PNBFAT ;ON SUCCESS, CONS UP ATOM FROM STRING
PPNAT2:
] ;END OF IFN CMU
PUSHN P,1
PUSH FXP,TT
TLZ TT,-1
PUSHJ P,PPNAT4 ;CONVERT PROGRAMMER
POP FXP,TT
HLRZS TT
PUSHJ P,PPNAT4 ;CONVERT PROJECT
JRST POPAJ
PPNAT4:
IFN TOPS10+CMU,[
CAIN TT,-1 ;777777 => OMITTED HALF OF PPN
SKIPA A,[Q.] ;REPLACE IT WITH *
JSP T,FXCONS ;OTHERWISE USE A FIXNUM
MOVE B,-1(P)
PUSHJ P,CONS
MOVEM A,-1(P)
POPJ P,
] ;END OF IFN TOPS10+CMU
IFN SAIL,[
CAIN TT,-1 ;777777 => OMITTED HALF OF PPN
JRST PPNAT9 ;REPLACE IT WITH *
JUMPE TT,PPNAT9 ;? MIGHT AS WELL TREAT 0 AS OMITTED
PPNAT6: TLNE TT,770000 ;LEFT JUSTIFY THE SIXBIT CHARACTERS
JRST PPNAT3 ;WHEN DONE, CREATE AN ATOM AND CONS ONTO LIST
LSH TT,6
JRST PPNAT6
] ;END OF IFN SAIL
SA$ PPNAT9: SKIPA A,[Q.]
PPNAT3:
20% PUSHJ P,SIXATM
20$ PUSHJ P,PNBFAT
PPNAT5: MOVE B,-1(P)
PUSHJ P,CONS
MOVEM A,-1(P)
POPJ P,
] ;END OF IFN D10
;CATPUS CATPS1 CATBAR CTCALL THRALL THROW5 THROW1 THROW6 THRNXT THROW7 THROW3 THRXIT THRSPC THRCAB THROW4 ERUNDO ERR0 GOBRK IOGBND EPOPJ
SUBTTL CATCH, THROW, ERRSET, .SET, AND BREAK ROUTINES
;NORMAL CATCH
CATPUS: PUSH P,B ;COMPILED CODE FOR *CATCH ENTERS HERE
MOVEI A,(A) ; COMPLR TURNS "CATCH" TO "*CATCH"
MOVEI T,(A)
LSH T,-SEGLOG
SKIPGE ST(T) ;SEE IF TAG OR TAGLIST
HRLI A,CATSPC\CATLIS
CATPS1: MOVEM A,CATID ;SET UP A CATCH FRAME
JSP T,ERSTP
MOVEM P,CATRTN
JRST (TT)
;CATCH-BARRIER
CATBAR: PUSH P,B ;ADR TO JUMP TO WHEN THROW IS DONE
HRLI A,CATSPC\CATLIS\CATCAB ;FLAG AS CATCH-BARRIER
MOVEM A,CATID ;THIS IS THE CATCH ID
JSP T,ERSTP ;SETUP A NEW CATCH FRAME
MOVEM P,CATRTN
JRST (TT)
;CATCHALL
; UPON ENTRY: TT HAS ADR-1 OF CATCHALL FUN, T HAS ADR AFTER OTHER FUNS
CTCALL: PUSH P,T
AOS TT ;POINT TO FIRST LOCATION OF CATCHALL FUN
HRLI TT,CATSPC\CATALL\CATCOM ;FLAG AS A COMPILED CATCHALL
MOVEM TT,CATID ;THIS IS THE CATCH ID
JSP T,ERSTP ;SETUP A NEW CATCH FRAME
MOVEM P,CATRTN
JRST -1(TT)
;BREAKUP A CATCHALL
THRALL: SETZM (P) ;TURN INTO A NORMAL CATCH
JRST THROW1 ;THEN BREAK UP LIKE A NORMAL THROW
THROW5: SKIPE D,UIRTN ;IF NO USER INTERRUPT FRAME STACKED,
CAIG D,(TT) ; OR IF IT IS BELOW THE CATCH FRAME,
JRST THROW3 ; THEN JUST EXIT THE CATCH FRAME
JSP TT,UIBRK ;OTHERWISE BREAK OUT OF THE INTERRUPT
THROW1: SKIPN TT,CATRTN ;SKIP IF CATCH FRAME BELOW US
JRST THROW4
MOVSI T,CATUWP
TDNE T,(TT) ;UNWIND-PROTECT FRAME?
JRST THRNXT ;YES, SKIP IT COMPLETELY
JUMPE B,THROW5
THROW6: SKIPN T,(TT) ;(CATCH FOO NIL) = (CATCH FOO)
JRST THROW5 ;CATCH ID MATCHES THROW ID
TLNE T,CATSPC ;SPECIAL PROCESSING NEEDED?
JRST THRSPC ;YES, DO SO
CAIN B,(T) ;CATCH ID MATCHES?
JRST THROW5 ;YES
THRNXT: MOVE TT,<-LEP1+1>+<CATRTN-ERRTN>(TT) ;GO BACK ONE CATCH
JUMPN TT,THROW6 ;FALL THROUGH IF NO MORE
THROW7: EXCH A,B
%UGT EMS29
EXCH A,B
JRST THROW1
THROW3: PUSHJ FXP,UNWPRO ;UNWIND PROTECT CHECKER
MOVE P,TT
THRXIT: SETZM PANICP
MOVSI D,-LEP1+1(P)
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
MOVE C,CATID ;GET CURRENT CATCH ID
SUB P,EPC1
POP P,FXP
POP P,FLP
POP P,TT
POP P,PA3
PUSHJ P,UBD0 ;RESTORE CONDITIONS AND PROCEED
TLNN C,CATALL ;A CATCHALL?
POPJ P, ;NOPE, RETURN THROWN VALUE
EXCH A,B ;TAG AS FIRST ARG, VAL AS SECOND
TLNE C,CATCOM ;COMPILED?
JRST (C) ;YES, RUN COMPILED CODE
CALLF 2,(C) ;ELSE CALL THE USER'S FUNCTION
POPJ P, ;RETURN NEW VAL IF THE CATCHALL FUN RETURNS
THRSPC: TLNE T,CATALL ;CATCHALL?
JRST THROW5 ;YES, WE HAVE FOUND A GOOD FRAME TO STOP AT
TLNE T,CATUWP ;UNWIND-PROTECT?
JRST THRNXT ;YES, IGNORE THE FRAME
TLNE T,CATCAB ;CATCH-BARRIER?
JRST THRCAB
TLNN T,CATLIS ;A LIST OF TAGS?
LERR [SIXBIT\SPECIAL CATCH FRAME, BUT NO VALID TYPE BITS EXIST!\]
PUSH P,A
PUSH P,B ;SAVE NEEDED ACS
MOVEI A,(B) ;CATCH TAG
MOVEI B,(T) ;LIST OF TAGS
PUSHJ P,MEMQ1 ;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT)
MOVE T,A ;SAVE THE RESULTS
POP P,B
POP P,A
JUMPE T,THRNXT ;UPWARD TO NEXT CATCH FRAME
JRST THROW5 ;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW
THRCAB: PUSH P,A
PUSH P,B ;SAVE NEEDED ACS
MOVEI A,(B) ;CATCH TAG
MOVEI B,(T) ;LIST OF TAGS
PUSHJ P,MEMQ1 ;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT)
MOVE T,A ;SAVE THE RESULTS
POP P,B
POP P,A
JUMPE T,THROW7 ;CATCH-BARRIER, NOT IN LIST OF TAGS, ERROR
JRST THROW5 ;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW
THROW4: JUMPN B,THROW7 ;NO CATCH FRAME -- GIVE UGT EROR
JRST LSPRET ;IF NO THROW TAG, THROW TO TOP LEVEL
JRST THRALL ;COMPILED REMOVAL OF A CATCHALL
JRST THROW1 ;COMPILED THROWS COME HERE
ERUNDO: SKIPN ERRTN ;COMPILED ERR, AND NORMAL ERRSET EXIT COME HERE
JRST LSPRET ;RETURN TO TOPLEVEL
ERR0:
IFN USELESS, SETZM TYOSW
JUMPN A,ERUN0 ;ELSE, BREAK UP AN ERRSET
SKIPE V.RSET
SKIPN VERRSET ;ERRSET BEING BROKEN BY AN ERROR
JRST ERUN0
PUSH P,A
MOVEI D,1001 ;ERRSET USER INTERRUPT
PUSHJ P,UINT
POP P,A
JRST ERUN0
SKIPA TT,CATRTN ;PHOOEY, COMPILED CODE COMES HERE WHEN A
GOBRK: MOVE TT,ERRTN ;GO OR RETURN OCCURS WITHIN AN ERRSET OR CATCH
JUMPE TT,ER4
EXCH T,-LERSTP(TT)
JRST ERR1
IOGBND: JSP T,SPECBIND ;BIND ALL I/O CONTROL VARIABLES TO NIL:
TTYOFF ; ↑W
TAPRED ; ↑Q
TAPWRT ; ↑R
EPOPJ: POPJ P, .SEE $ERRFRAME
;BRGEN BRLP1 BRLP BRLP2 BRLP4 BRLP3
;;; MOVEI D,LOOP ;ROUTINE TO LOOP
;;; PUSHJ P,BRGEN
;;; GENERATES A BREAK LOOP SURROUNDED BY A CATCH AND AN
;;; ERRSET. ERRORS CAUSE THE LOOP TO BE RE-ENTERED.
;;; BRGEN RETURNS WHEN THE LOOP ROUTINE PERFORMS A
;;; THROW TO THE TAG BREAK.
.SEE BREAK
.SEE $BREAK
BRGEN: MOVEI A,QBREAK ;CATCH ID = BREAK
JSP TT,CATPS1 ;SET UP CATCH FRAME
PUSH P,D
PUSH P,. ;RETURN POINT FOR ERROR
JSP T,ERSTP ;SET UP ERRSET FRAME
SETOM ERRSW
MOVEM P,ERRTN
JRST @-LERSTP-1(P) ;CALL RANDOM ROUTINE
;;; BREAK LOOP USED BY *BREAK
BRLP1: PUSH P,FLP
PUSH P,FXP
PUSH P,SP
PUSHJ P,TLEVAL ;EVALUATE FORM READ
MOVEM A,V. ;STICK VALUE IN *
PUSHJ P,TLPRINT ;PRINT VALUE
HRRZ TT,-2(P)
HRRZ D,-1(P)
HRRZ R,(P)
POPI P,3
PUSHJ P,PDLCHK ;CHECK PDL LEVELS
JRST TLTERPRI ;TERPRI IF APPROPRIATE
BRLP: PUSH P,BRLP ;***** BASIC BREAK LOOP *****
SKIPE A,BLF ;IF USER SUPPLIED A BREAK LOOP FORM,
JRST EVAL ; EVALUATE IT (RETURNS TO BRLP)
PUSHJ P,TLREAD ;OTHERWISE READ A FORM
SKIPE VDOLLRP ;IF THE FORM IS EQ TO THE
CAME A,VDOLLRP ; NON-NIL VALUE OF THE VARIABLE ≠P,
JRST BRLP4 ; THEN THAT MEANS RETURN NIL
MOVEI A,NIL
BRLP2: MOVEI B,QBREAK
JRST THROW1 ;ESCAPE FROM BRGEN LOOP
BRLP4: HLRZ B,(A) ;(RETURN <FOO>) MEANS RETURN THE
CAIE B,QRETURN ; VALUE OF FOO
JRST BRLP1 ;OTHERWISE EVAL AND PRINT THE FORM
JSP T,%CADR
BRLP3: PUSHJ P,EVAL
JRST BRLP2
;.STORE .STOR0 .STOR1 .STOR2 .STOR4 .STOR4
;;; JSP T,.STORE ;USED BY COMPILED CODE
;;; ON CALLING .STORE WE MUST HAVE JUST COMPLETED AN "INTERPRETED"
;;; ARRAY REFERENCE OF SOME KIND, BY PUSHJ'ING INTO THE ARRAY HEADER
;;; AND GOING TO ONE OF THE NDIMX ROUTINES. THIS LEAVES THE SAR
;;; OF THE ARRAY REFERENCED IN LISAR, AND THE INDEX WORD IN R.
;;; A CONTAINS THE VALUE TO STORE INTO THE ARRAY.
.STORE: SKIPN D,LISAR
JRST .STOLZ ;ERROR IF NO ARRAY REFERENCED LATELY
HLL D,ASAR(D)
TLNN D,AS.SX ;WAS IT AN S-EXPRESSION ARRAY?
JRST .STOR2
.STOR0: MOVEI TT,(R) ;YEP, STORE A HALF-WORD QUANTITY
JUMPL R,.STOR1
HRLM A,@TTSAR(D)
JRST (T)
.STOR1: HRRM A,@TTSAR(D)
JRST (T)
.STOR2: TLNN D,AS.FX+AS.FL ;SKIP IF FIXNUM OR FLONUM
IFN DBFLAG+CXFLAG, JRST .STOR4
.ELSE .VALUE
MOVEI F,(T)
TLNN D,AS.FX
JSP T,FLNV1X ;GET FLONUM QUANTITY, WITH SKIP RETURN
JSP T,FXNV1 ;OR MAYBE GET FIXNUM QUANTITY
EXCH TT,R
MOVEM R,@TTSAR(D) ;STORE QUANTITY INTO ARRAY
JRST (F)
IFN DBFLAG+CXFLAG,[
.STOR4: TLNN D,AS.DB+AS.CX ;SKIP IF DOUBLE OR COMPLEX
IFN DXFLAG, JRST .STOR6
.ELSE .VALUE
MOVEI F,(T)
DB$ CX$ TLNN D,AS.DB
DB$ CX$ JSP T,CXNV1X ;GET COMPLEX QUANTITY, WITH SKIP RETURN
DB$ JSP T,DBNV1 ;OR MAYBE GET DOUBLE QUANTITY
DB% JSP T,CXNV1
MOVE T,LISAR
EXCH TT,R
MOVEM R,@TTSAR(T) ;STORE QUANTITY INTO ARRAY
ADDI TT,1
MOVEM D,@TTSAR(T)
JRST (F)
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
.STOR4: TLNN D,AS.DX ;SKIP IF DUPLEX
.VALUE ;IF NOT THAT, THEN ERROR (UNKNOWN ARRAY TYPE)
PUSH P,F
PUSH FXP,R
JSP T,DXNV1
MOVE T,LISAR
EXCH TT,(FXP)
KA MOVEM R,@TTSAR(T) ;STORE QUANTITY INTO ARRAY
KA ADDI TT,1
KA MOVEM F,@TTSAR(T)
KA ADDI TT,1
KIKL DMOVEM R,@TTSAR(T)
KIKL ADDI TT,2
POP FXP,@TTSAR(T)
ADDI TT,1
MOVEM D,@TTSAR(T)
POPJ P,
] ;END OF IFN DXFLAG
;.SET .SET1 FWNACK FWNAC1 LWNACK ERSTP LERSTP ERUN0 ERR1A ERR1 EPC1
;;; JSP T,.SET ;USED BY COMPILED CODE
;;; ATOM TO SET IN AR1, AND VALUE TO SET TO IN A.
;;; THE VALUE MUST NOT BE A PDL QUANTITY.
.SET: EXCH A,AR1
.SET1: PUSH P,A
PUSHJ P,BIND ;BIND TAKES SYMBOL IN A, VALUE IN AR1
POP P,A ;THIS CROCKISH IMPLEEMNTATION
EXCH A,AR1 ; PERFORMS A SET BY DOING A SPECBIND,
JRST SETXIT ; THEN DISCARDING THE BINDING FROM SP
;;; JSP TT,FWNACK ;OR LWNACK
;;; FAXXXX,,QFOO ;OR LAXXXX,,QFOO
;;; CHECKS FOR AN FSUBR (LSUBR) THAT THE RIGHT NUMBER OF ARGUMENTS
;;; WERE PROVIDED, AND GENERATES AN APPROPRIATE WNA ERROR IF NOT.
;;; THE FAXXXX (LAXXXX) HAS THE LOW BIT 0 FOR LSUBR, 1 FOR FSUBR.
;;; BIT 2←N IS SET IFF GETTING EXACTLY N ARGUMENTS IS ACCEPTABLE.
FWNACK: SETZ T, ;COUNT UP ACTUAL NUMBER OF ARGS
MOVEI D,(A) ;LEAVES NEGATIVE OF NUMBER OF ARGS IN T,
FWNAC1: JUMPE D,LWNACK ; SO CAN FALL INTO LSUBR CHECKER
HRRZ D,(D)
SOJA T,FWNAC1
LWNACK: MOVE D,(TT) ;GET WORD OF BITS
ASH D,(T)
TLNE D,2 ;SKIP UNLESS WNA
JRST 1(TT)
JRST WNAL0 ;GO PRODUCE A WRNG-NO-ARGS ERROR
;;; PUSH CRUFT FOR AN ERRSET/CATCH/READEOF FRAME
;;; BEWARE! THE COMPILER DEPENDS ON THE LENGTH OF THE
;;; ERRSET FRAME BEING A CONSTANT.
ERSTP: PUSH P,PA3 ;"ERRSET" PUSH
PUSH P,SP ;MUST SAVE TT - SEE $TYI
PUSH P,FLP
PUSH P,FXP
REPEAT LEP1, PUSH P,ERRTN+.RPCNT
LERSTP==.-ERSTP ;LENGTH OF ERRSET PUSH
JRST (T)
ERUN0: HRRZ TT,ERRTN ;GENERAL BREAK OUT OF AN ERRSET
SKIPE D,UIRTN
CAIL TT,(D)
JRST ERR1A
JSP TT,UIBRK ;MAYBE BREAK UP A USER INTERRUPT FIRST
JRST ERUN0
ERR1A: HRRZ TT,ERRTN ;WHERE WE ARE UNWINDING TO
PUSHJ FXP,UNWPRO ;HANDLE UNWIND-PROTECT
MOVE P,ERRTN
ERR1: SETZM PANICP
MOVSI D,-LEP1+1(P)
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,EPC1
POP P,FXP
POP P,FLP
POP P,TT
POP P,PA3
JRST UBD0 ;RESTORE CONDITIONS AND PROCEED
EPC1: LEP1,,LEP1
;UIBRK UNWPRO UNWPR2 UNWPR1 UNWPUS UNWNCM UNWNXT UNWPRT
UIBRK: EXCH D,TT ;UNWIND-PROTECT NEEDS STACK POINTER IN AC TT
PUSHJ FXP,UNWPRO ;HANDLE UNWIND PROTECTION
EXCH D,TT
HRRM TT,-1(D)
HRRO FXP,1(D) ;JUST SET LEFT HALF OF PDL POINTERS
HLRO FLP,1(D) ; TO -1 FOR BIBOP, AND LET PDLOV
HRROI P,-UIFRM(D)
MOVEM F,UISAVT-T+F(FXP) ;LET F BE SAFE OVER RESTORATION
MOVEM T,UISAVT(FXP) ;T TOO
MOVEM C,UISAVA-A+C(P) ;C TOO
MOVEM B,UISAVA-A+B(P) ;B TOO
MOVEM A,UISAVA(P) ;A TOO
JRST UINT0X
;THIS ROUTINE FINDS ALL UNWIND-PROTECTS BETWEEN THE CURRENT STACK POSITION
; AND THE DESIRED STACK POSITION (AS FOUND IN TT). IF AN UNWIND-PROTECT IS
; FOUND, THEN:
; A) THE UNWIND-PROTECT STACK FRAME IS POP'ED *WITHOUT UPDATING FXP OR FLP*
; B) SP IS UNWOUND TO THE CURRENT BINDING LEVEL
; C) THE FUNCTION IS CALLED WITH EVERYTHING SAVED
; D) WHEN THE FUNCTION RETURNS, ACS ARE RESTORED AND THE ROUTINE CONTINUES
; SEARCHING FOR THE NEXT UNWIND PROTECT
; WHEN NO MORE UNWIND PROTECTS EXIST IN THE SPECIFIED RANGE OF THE PDL,
; THIS ROUTINE RETURNS TO ITS CALLER, WHICH IS EXPECTED TO RESTORE
; FXP AND FLP (AND POSSIBLY OTHERS) FROM THE STACK FRAME THAT WAS USED TO STOP
; THE UNWIND-PROTECT SEARCH
; CALLED WITH PUSHJ FXP,
; TT CONTAINS LOWEST ADR TO SEARCH
; PRESERVES ALL AC'S
UNWPRO:
;;; AMOUNT OF STUFF THAT GETS PUSHED MUST BE WELL DEFINED, CHANGE UNWPUS
;;; IF IT CHANGES
.SEE UNWPUS
PUSH FXP,D
PUSH FXP,T
PUSH FXP,R
PUSH FXP,TT
;;;
HRRZS TT ;ONLY PDL PART
MOVEI R,(SP) ;CURRENT VALUE OF SP IN CASE NO FRAMES FOUND
UNWPR2: SKIPE D,CATRTN
UNWPR1: CAILE TT,(D) ;HAVE WE GONE TOO FAR?
JRST UNWPRT ;NO MORE FRAMES POSSIBLE, SO RETURN
HRLZI T,CATUWP ;IS THIS AN UNWIND-PROTECT FRAME?
TDNN T,(D)
JRST UNWNXT ;NOT UNWIND-PROTECT, SO SKIP THIS FRAME
HRRO P,D ;RESET PDL, WILL WORK BY PDL OV NEXT PUSH
;;; PUSH NOTE
.SEE UNWPUS
PUSH FXP,UNREAL ;FROM THIS POINT ON ALLOW NO USER INT'S
;;;
SETOM UNREAL
LOCKI
MOVE T,(P) ;GET POINTER TO UNWIND HANDLER
MOVSI D,-LEP1+1(P) ;RESTORE HAS FRAME (SNARFED FROM ERR1)
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,EPC1
POP P,D ;GET OLD FXP
POP P,FLP ;RESTORE FLP
POP P,R ;SAVE LEVEL TO SP UNWIND TO
POP P,PA3
PUSHJ FXP,SAV5 ;SAVE ALL PROTECTED ACS
MOVEI B,(T) ;POINTER TO COMPILED FUNCTION OR LIST
UNLOCKI
;;; PUSH NOTE
.SEE UNWPUS
PUSHJ P,SAVX5 ;AND UNPROTECTED ONES
;;;
HRRI T,(D)
MOVEI TT,(R)
PUSHJ P,UBD0 ;UNWIND SP
MOVEI TT,(T)
TLNN T,CATCOM ;COMPILED CODE?
JRST UNWNCM ;NOPE, USE PROGN
UNWPUS==:13 ;NUMBER OF PUSHES DONE ON FXP
HRLI TT,-<UNWPUS-1>(FXP);BLT POINTER TO DATA THAT MUST BE MOVED
AOS TT
MOVEI D,UNWPUS-1(TT) ;BLT END POINTER
BLT TT,(D) ;BLT ALL IMPORTANT FXP DATA
HRROI FXP,(D) ;NEW FXP
PUSHJ P,(B) ;INVOKE THE UNWINDPROTECTION CODE
SKIPA
UNWNCM: PUSHJ P,IPROGN
MOVE A,-5(FXP) ;GET OLD VALUE OF UNREAL, ALSO SETS UP THIS VALUE
SKIPL A ;NO NEED TO CALL IF ALL INTERRUPTS BEING DEFFERED ANYWAY
PUSHJ P,CHECKU ;AND SEE IF INTERRUPTS TO BE RUN
PUSHJ P,RSTX5 ;RESTORE ACS
PUSHJ FXP,RST5
POP FXP,UNREAL ;WE'VE MADE SURE INTERRUPTS GET RUN, BUT MAY BE DEFFERING HERE
JRST UNWPR2
UNWNXT: MOVE D,<-LEP1+1>+<CATRTN-ERRTN>(D) ;GO BACK ONE CATCH
JUMPN D,UNWPR1 ;IF MORE FRAMES TO CHECK THEN GO ON
UNWPRT: POP FXP,TT
POP FXP,R
POP FXP,T
POP FXP,D
POPJ FXP,
;CIN0 CONS1PFX CONS1FX CONSPFX CONSFX CONSIT BAPOPJ ZPOPJ POPNVJ CCPOPJ 0POPJ POP2J CPOPJ POP3J POPAJ1 S1PAJ POPAJ CPOPAJ POP1J1 POPJ1 POP1J CPOP1J M1TTPJ POPCJ CPOPCJ UNLKFALSE UNLKTRUE PX1J CPXDFLJ PXDFLJ POPXDJ CPXDJ
SUBTTL VARIOUS COMMON EXITS
CIN0: IN0 ;SURPRISE!
;;; THESE ROUTINES ARE USEFUL FOR CONSING UP LISTS OF NUMBERS
;;; (AS STATUS FUNCTIONS OFTEN DO, FOR INSTANCE).
;;; A CALL TO CONS1FX WILL TAKE A NUMBER IN TT AND MAKE A SINGLETON
;;; LIST OF IT. SUCCESSIVE CALLS TO CONSFX WILL THEN TACK NEW NUMBERS
;;; ONTO THE FRONT OF THE LIST. CONS1PFX AND CONSPFX ARE SIMILAR,
;;; BUT POP THE NUMBER FROM FXP. IN THIS WAY ONE CAN PRODUCE NUMBERS
;;; IN FORWARDS ORDER, PUSHING THEM ON FXP, THEN USE THESE ROUTINES
;;; TO CONS THEM UP IN REVERSE ORDER, PRODUCING A FORWARDS LIST OF THEM.
CONS1PFX: TDZA B,B
CONS1FX: TDZA B,B
CONSPFX: POP FXP,TT
CONSFX: JSP T,FXCONS
CONSIT: PUSHJ P,CONS
BAPOPJ: MOVEI B,(A)
POPJ P,
;;; OTHER COMMON EXITS
ZPOPJ: TDZA TT,TT ;ZERO TT, THEN POPJ
POPNVJ: JSP T,FXNV1 ;FXNV1, THEN POPJ
CCPOPJ: POPJ P,CCPOPJ ;NOT CPOPJ! WILL SCREW BAKTRACE
0POPJ: SKIPA A,CIN0 ;PUT A LISP FIXNUM 0 IN A AND POPJ
POP2J: POPI P,2 ;POP 2 PDL SLOTS AND POPJ
CPOPJ: POPJ P,CPOPJ .SEE BAKTRACE ;SACRED TO BAKTRACE
POP3J: POPI P,3
POPJ P,
POPAJ1: AOSA -1(P) ;POP INTO A, THEN SKIP RETURN
S1PAJ: POPI P,1 ;POP 1 PDL SLOT, POP INTO A, AND POPJ
POPAJ: POP P,A ;POP A, THEN POPJ
CPOPAJ: POPJ P,POPAJ
POP1J1: AOSA -1(P) ;POP 1 PDL SLOT, THEN SKIP RETURN
POPJ1: AOSA (P) ;SKIPPING POPJ RETURN
POP1J: POPI P,1 ;POP 1 PDL SLOT AND POPJ
CPOP1J: POPJ P,POP1J
M1TTPJ: SKIPA TT,XC-1 ;-1 IN TT, THEN POPJ
POPCJ: POP P,C ;POP C, THEN POPJ
CPOPCJ: POPJ P,POPCJ
UNLKFALSE: TDZA A,A ;UNLOCK INTERRUPTS, RETURNING FALSE (NIL)
UNLKTRUE: MOVEI A,TRUTH ;UNLOCK INTERRUPTS, RETURNING TRUTH (T)
UNLKPOPJ
PX1J: POPI FXP,1 ;FLUSH 1 FXP SLOT, THEN POPJ P,
CPXDFLJ: POPJ P,PXDFLJ
PXDFLJ: HLLZ D,(P) ;POP FXP INTO D, THEN POPJ P,
JRST 2,POPXDJ(D) ; AND RESTORE FLAGS FROM THE P SLOT
POPXDJ: POP FXP,D ;POP FXP SLOT INTO D, THEN POPJ P,
CPXDJ: POPJ P,POPXDJ
;SAV5 SAV5M1 SAV5M2 SAV5M3 CPOPXJ SAV3 SAV2 SAV1 RST3 RST2 RST1 RST5 R5M1PJ RST5M1 CR5M1PJ RST5M2 RST5M3 SAVX5 SAVX3 RSTX5 PXTTTJ POPXTJ RSTX3 RSTX2 RSTX1 CPOPNVJ
SUBTTL VARIOUS COMMON SAVE AND RESTORE ROUTINES
SAV5: PUSH P,A
SAV5M1: PUSH P,B
SAV5M2: PUSH P,C
SAV5M3: PUSH P,AR1
PUSH P,AR2A
CPOPXJ: POPJ FXP,
SAV3: PUSH P,C
SAV2: PUSH P,B
SAV1: PUSH P,A
POPJ FXP,
RST3: POP P,A
POP P,B
POP P,C
POPJ FXP,
RST2: POP P,A
POP P,B
POPJ FXP,
RST1: POP P,A
POPJ FXP,
RST5: POP P,AR2A
POP P,AR1
POP P,C
POP P,B
POP P,A
POPJ FXP,
R5M1PJ: PUSH FXP,CCPOPJ
RST5M1: POP P,AR2A
POP P,AR1
POP P,C
POP P,B
CR5M1PJ: POPJ FXP,R5M1PJ
RST5M2: POP P,AR2A
POP P,AR1
POP P,C
POPJ FXP,
RST5M3: POP P,AR2A
POP P,AR1
POPJ FXP,
SAVX5: PUSH FXP,T
PUSHJ P,SAVX3
PUSH FXP,F
POPJ P,
SAVX3: PUSH FXP,TT
PUSH FXP,D
PUSH FXP,R
POPJ P,
RSTX5: POP FXP,F
POP FXP,R
POP FXP,D
PXTTTJ: POP FXP,TT
POPXTJ: POP FXP,T
POPJ P,
RSTX3: POP FXP,R
RSTX2: POP FXP,D
RSTX1: POP FXP,TT
CPOPNVJ: POPJ P,POPNVJ
;$ERRFRAME $EVALFRAME $UIFRAME L$EVALFRAME AFPOPJ $APPLYFRAME
SUBTTL VARIOUS KINDS OF FRAME MARKERS
$ERRFRAME=525252,,EPOPJ ;ERROR FRAME
$EVALFRAME=525252,,POP2J ;EVAL FRAME
;; $APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME DEFINED BELOW
$UIFRAME=525252,,CPOPAJ ;USER INTERRUPT FRAME
;;; FORMAT OF EVALFRAME:
;;; <FLP>,,<FXP>
;;; <SP>,,<FORM>
;;; $EVALFRAME
L$EVALFRAME==3 ;LENGTH OF EVALFRAME
;;; FORMAT OF APPLYFRAME:
;;; -- ARGS --
;;; <FLP>,,<FXP>
;;; <SP>,,<FUNCTION>
;;; $APPLYFRAME
.SEE L$EVALFRAME
;;; WHERE -- ARGS -- MAY BE ONE OF THREE THINGS, DEPENDING
;;; ON ITS LEFT HALF:
;;; LH=0 RH=LIST OF ARGS
;;; LH<0 LH,,RH=AOBJN POINTER TO ARGS VECTOR (E.G. FOR LSUBR)
;;; LH>0 RH=LAST ARG; OTHER ARGS ARE BELOW THIS ON THE
;;; STACK. IN THIS CASE THE APPLYFRAME MAY BE MORE
;;; THAN FOUR WORDS LONG.
;;; EXAMPLE: MOVEI A,QFOO
;;; MOVEI B,QBAR
;;; CALL 2,QUUX
;;; CAUSES THIS APPLYFRAME TO APPEAR ON THE STACK:
;;; 0,,QFOO
;;; 2,,QBAR
;;; <FLP>,,<FXP>
;;; <SP>,,QUUX
;;; $APPLYFRAME
AFPOPJ: HLRE T,-2(P) ;APPLYFRAME POPJ
SKIPG T ;FIGURE OUT LENGTH OF
MOVEI T,1 ; APPLY FRAME
ADDI T,2
HRLI T,(T)
SUB P,T ;POP CRUFT FROM PDL
POPJ P, ;RETURN
$APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME
;FLTSK1 FLTSK2 FLTSKP FLTSTB FLTSFX FLTSFL NVSKP2 NVSKIP NVSKTB NVSKFL
SUBTTL NUMERIC TYPE-TESTING, CONVERSION, AND VALUE ROUTINES
IFN BIGNUM+DBFLAG+CXFLAG,[
FLTSK1: %WTA NMV5 ;UNACCEPTABLE NUMERIC VALUE
IFE NARITH, JRST 2,@[FLTSKP] ;CLEAR PC FLAGS
] ;END OF IFN BIGNUM+DBFLAG+CXFLAG
FLTSK2: %WTA NMV3 ;NON-NUMERIC VALUE
IFE NARITH, JRST 2,@[FLTSKP] ;CLEAR PC FLAGS
FLTSKP: MOVEI TT,(A) ;"FLOAT SKIP" ROUTINE
LSH TT,-SEGLOG ; SKIPS 0 FOR FIXNUMS, 1 FOR FLONUMS (OR DOUBLES)
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
IFE NARITH, 2DIF JRST @(TT),FLTSTB,QLIST
IFN NARITH, 2DIF [JRST 2,@(TT)]FLTSTB,QLIST ;DISPATCH AND CLEAR PC FLAGS
FLTSTB: FLTSK2 ;LIST ;ERROR
FLTSFX ;FIXNUM ;SKIPS 0
FLTSFL ;FLONUM ;SKIPS 1
DB$ FLTSFL ;DOUBLE ;SKIPS 1
CX$ FLTSK1 ;COMPLEX;ERROR
DX$ FLTSK1 ;DUPLEX ;ERROR
BG$ FLTSK1 ;BIGNUM ;ERROR
FLTSK2 ;SYMBOL ;ERROR
HN$ REPEAT HNKLOG+1, FLTSK2 ;HUNKS ;ERROR
FLTSK2 ;RANDOM ;ERROR
FLTSK2 ;ARRAY ;ERROR
IFN .-FLTSTB-NTYPES, WARN [WRONG LENGTH TABLE]
IFN BIGNUM*<1-NARITH>, NVSKBG:
IFN BIGNUM*NARITH, NMSKBG:
FLTSFX: MOVE TT,(A)
JRST (T)
IFN BIGNUM*<1-NARITH>, NVSKFX:
FLTSFL: MOVE TT,(A)
JRST 1(T)
IFN BIGNUM*<1-NARITH>,[
NVSKP2: %WTA NMV3 ;NON-NUMERIC VALUE
NVSKIP: MOVEI TT,(A) ;"NUMERIC VALUE SKIP"
LSH TT,-SEGLOG ;SKIPS: 0 = BIGNUM, 1 = FIXNUM, 2 = FLONUM, ELSE ERROR
HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT
2DIF JRST @(TT),NVSKTB,QLIST .SEE STDISP
NVSKTB: NVSKP2 ;LIST ;ERROR
NVSKFX ;FIXNUM ;SKIPS 1
NVSKFL ;FLONUM ;SKIPS 2
DB$ NVSKP2 ;DOUBLE
CX$ NVSKP2 ;COMPLEX
DX$ NVSKP2 ;DUPLEX
BG$ NVSKBG ;BIGNUM ;SKIPS 0, LEAVES BIGNUM HEADER IN TT
NVSKP2 ;SYMBOL ;ERROR
HN$ REPEAT HNKLOG+1, NVSKP2 ;HUNKS ;ERROR
NVSKP2 ;RANDOM ;ERROR
NVSKP2 ;ARRAY ;ERROR
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]
NVSKFL: MOVE TT,(A)
JRST 2(T)
] ;END OF IFN BIGNUM*<1-NARITH>
;NMSKP2 NMSKIP NMSKTB NMSKFX NMSKFL
IFN NARITH,[
;;; NUMERIC SKIP ROUTINE
;;; JSP T,NMSKIP
;;; BG$ ... ;HERE FOR BIGNUMS; LEAVES HEADER IN TT
;;; DX$ ... ;HERE FOR DUPLEX
;;; CX$ ... ;HERE FOR COMPLEX
;;; DB$ ... ;HERE FOR DOUBLE; LEAVES FIRST WORD IN TT
;;; ... ;HERE FOR FLONUM; LEAVES VALUE IN TT
;;; ... ;HERE FOR FIXNUM; LEAVES VALUE IN TT
;;; ALSO CLEARS THE PC FLAGS
NMSKP2: %WTA NMV3 ;NON-NUMERIC VALUE
NMSKIP: MOVEI TT,(A)
LSH TT,-SEGLOG
HRRZ TT,ST(TT)
2DIF [JRST 2,@(TT)]NMSKTB,QLIST
;PC FLAGS IN THIS TABLE MUST BE ZERO
NMSKTB: NMSKP2 ;LIST
NMSKFX ;FIXNUM
NMSKFL ;FLONUM
DB$ NMSKDB ;DOUBLE
CX$ NMSKCX ;COMPLEX
DX$ NMSKDX ;DUPLEX
BG$ NMSKBG ;BIGNUM
NVSKP2 ;SYMBOL
HN$ REPEAT HNKLOG+1, NVSKP2 ;HUNKS
NVSKP2 ;RANDOM
NVSKP2 ;ARRAY
IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE]
NMSKFX: MOVE TT,(A)
JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG+1(T)
NMSKFL: MOVE TT,(A)
JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG(T)
DB$ NMSKDB: MOVE TT,(A)
DB$ JRST BIGNUM+DXFLAG+CXFLAG(T)
CX$ NMSKCX: JRST BIGNUM+DXFLAG(T)
DX$ NMSKDB: JRST BIGNUM(T)
] ;END OF IFN NARITH
;LR70 CDUPL1 CCMPL1 CDBL1 CFIX1 CFLOAT1 R70 ZZZ XC IFIX IFLOAT IFLT5 IFLT1 IFLT2 IFLT4 IFLT3
LR70==:20 ;LAP AND FASLAP HAVE THIS QUANTITY BUILT IN
CDUPL1: DUPL1 ;FOR (% 0 0 DUPL1)
CCMPL1: CMPL1 ;FOR (% 0 0 CMPL1)
CDBL1: DBL1 ;FOR (% 0 0 DBL1)
CFIX1: FIX1 ;FOR (% 0 0 FIX1)
CFLOAT1: FLOAT1 ;FOR (% 0 0 FLOAT1)
R70: REPEAT LR70, .RPCNT,,.RPCNT ;COMMON LAP CONSTANTS ALSO USED BY LISP CODE
ZZZ==5
IFL ZZZ-NACS, ZZZ==NACS ;NEED AT LEAST <NACS> OF THESE
REPEAT ZZZ, .RPCNT-ZZZ
XC:: ;WRITE "XC-N" TO GET THE CONSTANT -N FOR SMALL N
;;; INTERNAL FLONUM-TO-FIXNUM CONVERSION; DOES NO ERROR CHECKS.
;;; CONVERTS NUMBER IN TT TO BE A FIXNUM, CLOBBERING D.
;;; THE CONVERSION IS A "FLOOR" OR "ENTIER" FUNCTION.
;;; THAT IS, 3.5 => 3, BUT -3.5 => -4.
IFIX: MULI TT,400 ;EXPONENT IN TT, MANTISSA IN D
TSC TT,TT ;THIS HACK GETS MAGNITUDE OF EXPONENT
ASH D,-243(TT) ;SHIFT THE MANTISSA
MOVE TT,D ;RESULT IN TT
JRST (T)
;;; INTERNAL FIXNUM-TO-FLONUM CONVERSION. SAVES D.
IFLOAT: TLNE TT,777000 ;FOR POSITIVE INTEGERS 27. BITS OR LESS,
JRST IFLT1 ; CAN JUST USE FSC TO SCALE
IFLT5: FSC TT,233 ;FSC NORMALIZES RESULT
JRST (T)
IFLT1: TLC TT,777000 ;THE SAME HACK WORKS FOR NEGATIVE NUMBERS
TLCN TT,777000 ; WITH NO MORE THAN 27. SIGNIFICANT BITS
JRST IFLT5
IFLT2: MOVEM D,IFLT9 ;FOR 28. TO 35. BITS OF SIGNIFICANCE,
JUMPL TT,IFLT3 ; WE CONVERT THE LEFT AND RIGHT HALVES
HLRZ D,TT ; SEPARATELY, AND THEN ADD THEM, TRUNCATING
MOVEI TT,(TT)
IFLT4: FSC D,255 ;SCALE RIGHT HALF
FSC TT,233 ;SCALE LEFT HALF
FAD TT,D ;ADD TOGETHER
MOVE D,IFLT9 ;RESTORE D
JRST (T)
IFLT3: HLRO D,TT ;FOR NEGATIVE NUMBERS, WE MUST
HRROI TT,(TT) ; PRODUCE THE CORRECT SIGN
AOJA D,IFLT4
;FLNV1X EFLNV1 FLNV1 EDBNV1 DBNV1 CXNV1X ECXNV1 CXNV1 EDXNV1 DXNV1 RSXST
;;; NUMERIC VALUE ROUTINES. THESE CHECK AN S-EXPRESSION
;;; FOR BEING THE DESIRED NUMERIC TYPE, AND PRODUCE A
;;; WRNG-TYPE-ARG ERROR IF APPROPRIATE. OTHERWISE
;;; THE VALUE OF THE NUMBER IS LIFTED INTO TT (D,R,F).
COMMENT |FXNV1: FXNV2: FXNV3: FXNV4:|
;;; FXNV1 (2,3,4) TAKES S-EXP IN A (B,C,AR1) AND PUTS VALUE IN TT (D,R,F).
IRPC AC,,[1234]
EFXNV!AC:
IFN AC-A, EXCH A,AC
%WTA FXNMER
IFN AC-A, EXCH A,AC
FXNV!AC: MOVEI TT-1+AC,(AC) ;CHECK DATA TYPE
ROT TT-1+AC,-SEGLOG
SKIPL TT-1+AC,ST(TT-1+AC)
TLNN TT-1+AC,FX ;SKIP IFF FIXNUM
JRST EFXNV!AC ;LOSE
MOVE TT-1+AC,(AC) ;GET VALUE IN NUMERIC AC
JRST (T)
TERMIN
FLNV1X: AOJA T,FLNV1 ;FLNV1 WITH SKIP RETURN
EFLNV1: %WTA FLNMER
FLNV1: SKOTT A,FL ;GET FLONUM VALUE IN TT FROM A
JRST EFLNV1
MOVE TT,(A)
JRST (T)
IFN DBFLAG,[
EDBNV1: %WTA DBNMER
DBNV1: SKOTT A,DB ;GET DOUBLE VALUE IN (TT,D) FROM A
JRST EDBNV1 ;HIGH ORDER WORD IN TT, LOW ORDER IN D
KA MOVE TT,(A)
KA MOVE D,1(A)
KIKL DMOVE TT,(A)
JRST (T)
] ;END OF IFN DBFLAG
IFN CXFLAG,[
CXNV1X: AOJA T,CXNV1 ;CXNV1 WITH SKIP RETURN
ECXNV1: %WTA CXNMER
CXNV1: SKOTT A,CX ;GET COMPLEX VALUE IN (TT,D) FROM A
JRST ECXNV1 ;REAL PART IN TT, IMAGINARY IN D
KA MOVE TT,(A)
KA MOVE D,1(A)
KIKL DMOVE TT,(A)
JRST (T)
] ;END OF IFN CXFLAG
IFN DXFLAG,[
EDXNV1: %WTA DXNMER
DXNV1: SKOTT A,DX ;GET DUPLEX VALUE IN (R,F,TT,D) FROM A
JRST EFLNV1 ;REAL PART IN (R,F), IMAGINARY IN (TT,D)
KA REPEAT 4, MOVE TT+<2#.RPCNT>,.RPCNT(A)
KIKL DMOVE R,2(A)
KIKL DMOVE TT,(A)
JRST (T)
] ;END OF IFN DXFLAG
BAKPRO
RSXST: HRRZ TT,VREADTABLE ;READ CHARACTER SYNTAX
HRRZ TT,TTSAR(TT) ; TABLE SETUP
HRLI TT,((A)) ;USED AS INDIRECT ADDRESS WITH
MOVEM TT,RSXTB ;INDEX FIELD A
NOPRO
JRST (T)
;NPUSH 0PUSH 0.0PUSH CINTREL INTREL CHECKI ERSETUP
SUBTTL SUPPORT FOR LAP/FASLAP CODE
;;; USE THE PUSHN MACRO TO PUSH N NIL'S (0'S, 0.0'S) ONTO P (FXP, FLP).
;;; IT WILL GENERATE JSP T,NPUSH-N (0PUSH, 0.0PUSH) AS APPROPRIATE.
;;; COMPILED CODE USES THESE ROUTINES VERY FREQUENTLY.
REPEAT NNPUSH, CONC \NNPUSH-.RPCNT,NPUSH,: PUSH P,R70
NPUSH: JRST (T)
REPEAT N0PUSH, CONC \N0PUSH-.RPCNT,PUSH,: PUSH FXP,R70
0PUSH: JRST (T)
REPEAT N0.0PUSH, CONC \N0.0PUSH-.RPCNT,.PUSH,: PUSH FLP,R70
0.0PUSH: JRST (T)
CINTREL: INTREL ;RANDOM USEFUL RETURN ADDRESS
INTREL: POP FXP,INHIBIT .SEE UNLOCKI ;COME HERE TO PERFORM AN UNLOCKI
CHECKI: SKIPN NOQUIT ;CHECK FOR DELAYED INTRRUPTS
SKIPN INTFLG
POPJ P, ;EXIT IF NONE
JRST CKI0 ;ELSE GO PROCESS
.SEE INTXIT
JRST CTCALL ;CATCHALL IN COMPILED CODE
JRST CATBAR ;CATCH-BARRIER IN COMPILED CODE
JRST CATPUS ;COMPILED CODE CALLS CATCH
ERSETUP:
PUSH P,B ;COMPILED CODE CALLS ERRSET
JSP T,ERSTP
MOVEM P,ERRTN
SETZM ERRSW
SKIPE A ;VALUE IN A DESCRIBES WHETHER ERRORS PRINT
SETOM ERRSW
JRST (TT)
;.LCALL .LCAF5 .LCAF7 .LCAFX .LCAFL .LCADB .LCACX .LCADX
SUBTTL SUPPORT FOR COMPILED LSUBRS
;;; ORDINARY TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH
;;; JSP D,.LCALL
;;; NUMERIC TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH
;;; JSP D,.LCALL-N ;N IS A FUNCTION OF THE TYPE
;;; JSP D,.LCALL
;;; THIS ROUTINE TAKES CARE OF BINDING ARGLOC AND ARGNUM FOR THE
;;; BENEFIT OF THE ARG, SETARG, AND LISTIFY FUNCTIONS,
;;; AND TAKE CARE OF FLUSHING THE ARGUMENTS FROM THE STACK.
;;; THE ORDER OF THESE ENTRY POINTS IS BUILT INTO THE COMPILER
JRST .LCADX ;SETUP FOR DUPLEX TYPE COMPILED LSUBRS
JRST .LCACX ;SETUP FOR COMPLEX TYPE COMPILED LSUBRS
JRST .LCADB ;SETUP FOR DOUBLE TYPE COMPILED LSUBRS
JRST .LCAFL ;SETUP FOR FLONUM TYPE COMPILED LSUBRS
JRST .LCAFX ;SETUP FOR FIXNUM TYPE COMPILED LSUBRS
.LCALL: PUSH P,R70 ;SETUP FOR REGULAR COMPILED LSUBRS, OR NCALL ENTRY
.LCAF5: MOVN TT,T ;NUMBER OF ARGS
ADDI T,-1(P) ;ADDR OF BEGINNING OF ARG VECTOR
CAIL TT,XHINUM ;XHINUM IS TYPICALLY >777, SO THERE'S LITTLE
JRST LXPRLZ ; CHANCE OF THIS SCREW, BUT BETTER BE SAFE
MOVEI A,IN0(TT)
MOVEI TT,(T)
JSP T,SPECBIND
0 TT,ARGLOC ;ARGLOC HOLDS PDL POSITION FOR VECTOR OF LSUBR ARGS
0 A,ARGNUM ;ARGNUM IS NUMBER OF ARGS, AS A LISP FIXNUM
PUSHJ P,(D) ;CALL THE USER FUNCTION, NUMBER OF ARGS IN A
POP P,D
SKIPN T,@ARGNUM
JRST .LCAF7 ;MIGHT AS WELL BUM FOR NO ARGUMENTS
HRLS T ;GOT TO GET RID OF THE ARGUMENTS
SUB P,T
.LCAF7: JUMPE D,UNBIND ;THIS EXIT SIGNALS CALL TO NOTYPE LSUBR, OR NCALL TO NUMERIC
PUSH P,D ;ELSE EXIT THROUGH FIX1 OR EQUIVALENT,
JRST UNBIND ; MEANING REGULAR CALL TO NUMERIC LSUBR
.LCAFX: PUSH P,CFIX1 ;PUSH ADDRESS FOR CONVERTINGMACHINE NUMBER TO FIXNUM
AOJA D,.LCAF5 ;INCREMENT D PAST THE CALL TO .LCALL-0 WHICH FOLLOWS
.LCAFL: PUSH P,CFLOAT1
AOJA D,.LCAF5
.LCADB:
DB$ PUSH P,CDBL1
DB$ AOJA D,.LCAF5
DB% LERR [SIXBIT \CALL TO DOUBLE-TYPE USER LSUBR!\]
.LCACX:
CX$ PUSH P,CCMPL1
CX$ AOJA D,.LCAF5
CX% LERR [SIXBIT \CALL TO COMPLEX-TYPE USER LSUBR!\]
.LCADX:
DX$ PUSH P,CDUPL1
DX$ AOJA D,.LCAF5
DX% LERR [SIXBIT \CALL TO DUPLEX-TYPE USER LSUBR!\]
;NORET .RSET NOUUO LIST LISTX LISTX3 KLIST JLIST ILIST ILIST1 ILIST3 GTRDTB GTRDT8
;;; THESE THREE FUNCTIONS MERELY SAVE THE LOSER THE TROUBLE OF TYPING "SETQ ".
NORET: PUSHJ P,NOTNOT ;SUBR 1
HRRZM A,VNORET
POPJ P,
.RSET: PUSHJ P,NOTNOT ;SUBR 1
MOVEM A,V.RSET
POPJ P,
NOUUO: PUSHJ P,NOTNOT ;SUBR 1
HRRZM A,VNOUUO
POPJ P,
SUBTTL VARIOUS LISTING AND DE-LISTING ROUTINES
LIST: PUSH FXP,CCPOPJ ;LSUBR
LISTX: MOVEI A,NIL ;BASICALLY, THE FUNCTION "LIST"
SKIPN R,T ; CALLED WITH A PUSHJ FXP,
LISTX3: JUMPE R,CPOPXJ
MOVEI B,(A) ;CLOBBERS A,B,T,TT,R
POP P,A
JSP T,PDLNMK
JSP T,%CONS
AOJA R,LISTX3
;;; INTERNAL LISTING FUNCTION; EVALUATES A LIST OF ARGS,
;;; STACKING THEIR VALUES ON THE PDL
KLIST: HLRZ B,(A) ;SUPER-HACKISH VERSION
PUSH P,B
HRRZ A,(A)
JLIST: HLRZ B,(A) ;HACKISH VERSION WHICH DOESN'T
PUSH P,B ; EVAL FIRST ARG OR COUNT IT
HRRZ A,(A)
ILIST: MOVEI T,0 ;CALLED BY JSP TT,ILIST
JUMPE A,(TT)
PUSH FXP,TT
PUSH FXP,T ;CONTAINS 0 - USED AS COUNTER
PUSH FXP,R ;MUST SAVE R!
ILIST1: PUSH P,A ;OTHERWISE, THIS EVAL LOOP
HLRZ A,(A) ; MAY CLOBBER ANYTHING
PUSHJ P,EVAL
ILIST3: EXCH A,(P) ;SAVE VALUE ON STACK
HRRZ A,(A)
SOS -1(FXP) ;COUNT VALUES
JUMPN A,ILIST1
POP FXP,R ;RESTORE R
POP FXP,T ;T HAS -<# OF VALUES ON PDL>
POPJ FXP,
;;; JSP T,GTRDTB ;GETS READTABLE IN AR2A, AND MAYBE CHECKS FOR ERRORS.
GTRDTB: HRRZ AR2A,VREADTABLE
SKIPN V.RSET ;ERROR CHECKS IFF *RSET NON-NIL
JRST (T)
SKOTT AR2A,SA
JRST GTRDT8 ;ERROR IF NOT ARRAY
MOVE TT,ASAR(AR2A)
TLNE TT,AS<RDT> ;ERROR IF NOT READTABLE TYPE ARRAY
JRST (T)
GTRDT8: MOVEI AR2A,READTABLE ;ON ERROR, RESTORE TO STANDARD READTABLE
EXCH AR2A,VREADTABLE
EXCH AR2A,A
PUSHJ P,GTRDT9 ;GIVE OUT A FAIL-ACT
MOVEI A,(AR2A)
JRST GTRDTB ;TRY AGAIN IF LOSER RETURNS TO US
;NOINTERRUPT NOINT0 CHECKU CHECKQ NOINT1 NOINT5 NOINT3 NOINT4 NOINTA NOINT2 ENOINT
SUBTTL NOINTERRUPT FUNCTION
NOINTERRUPT: JUMPE A,CHECKU ;SUBR 1 - ENABLE/DISABLE
CAIN A,QTTY
JRST CHECKU
SETO A, ; RANDOM ASYNCHRONOUS
NOINT0: EXCH A,UNREAL ; "REAL TIME" INTERRUPTS
SKIPGE A ; (CLOCKS AND TTY)
MOVEI A,TRUTH
POPJ P,
;;; CHECK FOR ANY DELAYED "REAL TIME" INTERRUPTS, AND RUN THEM
;;; IF ANY. MUST DO THEM IN THE ORDER ↑G/↑X, CLOCKS, AND OTHER.
;;; NOTE THAT AFTER A ↑G OR ↑X, CHECKU GETS CALLED AGAIN.
CHECKU: SKIPN UNREAL ;NONE CAN BE PENDING IF NOT DELAYING
JRST NOINT0
CHECKQ: PUSH P,A
PUSHJ P,UINTPU
NOINT1: SKIPE (P)
JRST NOINT5
SKIPE D,UNRC.G ;PROCESS ↑G/↑X FIRST
JRST CKI2A ;TOP LEVEL OR ERRRTN WILL DO A CHECKU
NOINT5: PUSHJ P,NOINTA ;NOW PROCESS ALARMCLOCK INTERRUPTS
JRST NOINT1
NOINT3: SKIPG F,UNREAR ;NOW ANY OTHER INTERRUPTS
JRST NOINT4
SOS UNREAR
MOVE D,UNREAR(F)
TRNE D,400000 ;IF (NOINTERRUPT 'TTY), SUPPRESS
SKIPN (P) ; TTY INTERRUPTS AT THIS TIME
PUSHJ P,YESINT ;MAY CLOBBER R (SEE UISTAK)
JRST NOINT1
NOINT4: SKIPG A,UNREAL
MOVEI A,TRUTH
POP P,UNREAL
JRST UINTEX
;;; DO NOT TRANSFORM THE "PUSHJ, POPJ" SEQUENCES INTO "JRST".
;;; YESINT DEPENDS ON LOOKING AT THE PUSHJ ADDRESS TO SEE WHETHER
;;; WE CAME FROM NOINTERRUPT OR ELSEWHERE!
NOINTA: SKIPN D,UNRRUN
JRST NOINT2
SETZM UNRRUN
PUSHJ P,YESINT
POPJ P,
NOINT2: SKIPN D,UNRTIM
JRST POPJ1
SETZM UNRTIM
PUSHJ P,YESINT
POPJ P,
ENOINT::. .SEE UINT0N
;CARCDR %CADDDR %CADDAR %CADDR %CADAR %CADR %CAAR %CAR %CDDDDR %CDDDAR %CDDDR %CDDAR %CDDR %CDAR %CDR %CAADDR %CAADAR %CAADR %CAAAR %CDADDR %CDADAR %CDADR %CDAAR %CAAADR %CAAAAR %CDDADR %CDDAAR %CDAADR %CDAAAR %CADADR %CADAAR
SUBTTL CAR/CDR ROUTINES AND FUNCTIONS
;;; HERE BELOW FOLLOW THE "FAST" CAR-CDR ROUTINES,
;;; USED WHEN *RSET=NIL, AND BY COMPILED CODE.
;;; NOTE THAT THE RELATIVE DISPLACEMENT OF THE FUNCTION ENTRY POINTS
;;; IS VERRRRRY IMPORTANT TO THE POOOR COMPLR.
;;; DONT EVER CHANGE THEM!!
CARCDR: ;INDEX NUMBER FOR CALL BY COMPILED CODE
%CADDDR: SKIPA A,(A) ; 0
%CADDAR: HLRZ A,(A) ; 1
%CADDR: SKIPA A,(A) ; 2
%CADAR: HLRZ A,(A) ; 3
%CADR: SKIPA A,(A) ; 4
%CAAR: HLRZ A,(A) ; 5
%CAR: HLRZ A,(A) ; 6
JRST (T)
%CDDDDR: SKIPA A,(A) ; 8
%CDDDAR: HLRZ A,(A) ; 9
%CDDDR: SKIPA A,(A) ;10.
%CDDAR: HLRZ A,(A) ;11.
%CDDR: SKIPA A,(A) ;12.
%CDAR: HLRZ A,(A) ;13.
%CDR: HRRZ A,(A) ;14.
JRST (T)
%CAADDR: SKIPA A,(A) ;16.
%CAADAR: HLRZ A,(A) ;17.
%CAADR: SKIPA A,(A) ;18.
%CAAAR: HLRZ A,(A) ;19.
JRST %CAAR
%CDADDR: SKIPA A,(A) ;21.
%CDADAR: HLRZ A,(A) ;22.
%CDADR: SKIPA A,(A) ;23.
%CDAAR: HLRZ A,(A) ;24.
JRST %CDAR
%CAAADR: SKIPA A,(A) ;26.
%CAAAAR: HLRZ A,(A) ;27.
JRST %CAAAR
%CDDADR: SKIPA A,(A) ;29.
%CDDAAR: HLRZ A,(A) ;30.
JRST %CDDAR
%CDAADR: SKIPA A,(A) ;32.
%CDAAAR: HLRZ A,(A) ;33.
JRST %CDAAR
%CADADR: SKIPA A,(A) ;35.
%CADAAR: HLRZ A,(A) ;36.
JRST %CADAR
;%CARCDR CRSUBRS CR0 CR1 CR1A CR2 CR3 CR7 CR4 CR5 CR6 NTH NTHCDR NTHCD5 NTHCD6 NTHCD1 NTHCD0 NTHCD2 NTHCD4
;;; THE FOLLOWING TABLE IS A TRANSFER VECTOR: GIVEN THE INFO-NUMBER
;;; OF A CAR-CDR OPERATION, SAY N, THEN CARCDR[N-2] IS THE
;;; ADDRESS OF THE FAST ROUTINE FOR THAT OPERATION. NOTE THAT THE
;;; INFO-NUMBER IS NOT THE SAME AS THE INDEX-NUMBER-FOR-COMPILED-CODE
%CARCDR:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
%C!X!R
TERMIN
;;; STANDARD INTERPRETER SUBRS FOR THE VARIOUS CAR-CDR
;;; OPERATIONS. THESE CALL A CENTRAL DECODER WHICH IN *RSET
;;; MODE PERFORMS TYPE CHECKING ON THE OPERAND AT EACH STEP.
CRSUBRS:
IRP X,,[A,D,AA,AD,DA,DD
AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD
AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD
DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]
C!X!R: JSP F,CR0
TERMIN
;;; LET A=0, D=1, AND LET CWXYZR BE A CAR-CDR OPERATION, WITH
;;; THE VARIABLES W,X,Y,Z RANGING OVER {,A,D}. LET A NUMBER N
;;; BE COMPUTED CORRESPONDING TO CXYZWR AS FOLLOWS:
;;; N = Z + 2 IF W,X,Y ARE NULL
;;; N = Y*2 + Z + 4 IF W,X ARE NULL
;;; N = X*4 + Y*2 + Z + 10 IF W IS NULL
;;; N = W*10 + X*4 + Y*2 + Z + 20 IF NONE OF W,X,Y,Z ARE NULL
;;; NOTE TWO THINGS:
;;; [1] THIS REPRESENTATION OF A CAR-CDR OPERATION IS EASILY
;;; BITWISE DECODABLE. THE POSITION OF THE FIRST 1 BIT
;;; INDICATES THE START OF THE REST OF THE ENCODING, WHICH HAS
;;; 0 FOR CAR, 1 FOR CDR AT EACH POSITION.
;;; [2] FOR ANY SET OF OPERATIONS COMPLETE FROM CAR AND CDR,
;;; THROUGH CAAR, CADR, ... TO "LEVEL M" CAR-CDR'S (THOSE WITH
;;; M A'S AND D'S), THIS ENCODING PRODUCES A COMPACT ENCODING,
;;; M+1
;;; WITH N RANGING FROM 2 TO 2 -1 INCLUSIVE.
;;;
;;; NAME N (OCTAL) N (BINARY)
;;; CAR 2 10
;;; CDR 3 11
;;; CAAR 4 100
;;; CADR 5 101
;;; . . .
;;; CDDADR 35 11101
;;; CDDDAR 36 11110
;;; CDDDDR 37 11111
CR0: SKIPE V.RSET
JRST CR1
POP P,T
JRST @%CARCDR-<CRSUBRS+1>(F) ;QUICK VERSION FOR *RSET = NIL
CR1: PUSHJ P,SAVX3 ;COMPILED CODE ASSUMES NUMACS SAFE
CR1A: MOVEI D,(A)
2DIF [MOVEI T,(F)]400002,CRSUBRS+1 ;400000 IS FOR CA.DER
CR2: SKOTT D,LS ;CHECK FOR LIST TYPE
JRST CR4
CR3: TRNE T,1 ;SKIP IF CAR OPERATION
SKIPA D,(D)
HLRZ D,(D)
ROT T,-1
TRNE T,776 ;SKIP IF ALL DONE
JRST CR2
CR7: MOVEI A,(D)
JRST RSTX3 ;COMPILED CODE ASSUMES NUMACS SAFE
CR4: TRNE T,1 ;IF NEXT ARG ISN'T A LIST
SKIPA R,VCDR ;THEN CHECK OUT AGAINST PERMISSIBLITIES
MOVE R,VCAR
JUMPN R,CR5
TRNN D,-1 ;IF ONLY NIL AND LISTS PERMISSIBLE
JRST CR7 ;THEN LET NIL BECOME NIL (CAR NIL) = (CDR NIL) = NIL
JRST CA.DER ;ELSE, BOMB OUT
CR5: CAIE R,QSYMBOL
JRST CR6
TRNE D,-1
TLNE TT,SY
JRST CR3
JRST CA.DER ;LOSE IF NEITHER NIL NOR SYMBOL
CR6: CAIN R,QLIST
JRST CA.DER ;LIST TEST ON ARG HAS ALREADY FAILED, SO FAIL
JRST CR3 ;IF CAR,CDR NOT "LIST", "SYMBOL", OR "NIL",
; THEN OK FOR ANYTHING
;;; NTH and NTHCDR - if *RSET is off, try to do fastly
; (NTH N FOO) RETURNS THE NTH CAR [WHERE (NTH 0 FOO) IS (CAR FOO)]
; EQUIVALENT TO (CAR (NTHCDR N FOO))
; (NTHCDR N FOO) RETURNS THE RESULT OF 'N' CDR'S
NTH: TDZA R,R
NTHCDR: MOVEI R,TRUTH ;R IS "NTHCDR"P FLAG - () ==> "NTH"
NTHCD5: SKIPN D,V.RSET
JRST NTHCD6
SKOTT A,FX
JRST NTHIEN
NTHCD6: MOVE TT,(A)
JUMPLE TT,NTHCD0 ;MUST BE NON-NEGATIVE
EXCH A,B ;RESULT TO BE RETURNED IN A
JUMPN D,NTHCD2 ;*RSET ==> DO ERROR CHECK ON EACH ELEMENT
NTHCD1: HRRZ A,(A) ;DO A CDR
SOJG TT,NTHCD1 ;LOOP UNTIL APPROPRIATE NUMBER OF CDR'S DONE
JUMPE R,$CAR
POPJ P, ;THEN RETURN
NTHCD0: JUMPG TT,NTHCD5 ;INDEX "0"
EXCH A,B
JUMPN R,CPOPJ ;JUST EXIT FOR NTHCDR
JUMPE D,$CAR ;BECOME "CAR" FOR (NTH 0 X)
JRST CAR
NTHCD2: MOVE F,(B)
SOS F
PUSHJ P,LASTCK ;TAKE "(F)" CDRS, SKIP IF SUCCESSFUL
JRST NTHER ; ERROR IF ARG-1 CDRS IS ATOMIC
JUMPN R,NTHCD4
HRRZ D,(D)
SKOTT D,LS
JUMPN D,NTHER
HLRZ A,(D) ;FOR "NTH"
POPJ P,
NTHCD4: HRRZ A,(D) ;FOR "NTHCDR", TAKE FINAL CDR
POPJ P,
;PNGNK PNGNK1 PNGNK2 SYCONS SYCON2 SYCON1 PSYCONS PNCONS PNG2 CPXTJ
SUBTTL SYMBOL CONSER
PNGNK: ADDI C,PNBUF-1 ;ONLY BY INTERN - PURIFIES PNAME IF RELEVANT
SKIPGE LPNF ;IF LPNF IS NEGATIVE, THE PNAME IS IN PNBUF,
PUSHJ P,PNCONS ; SO WE CONS IT UP NOW
SKIPE B,V.PURE
CAIN B,QSYMBOL
JRST SYCONS ;NO PURE COPY NEEDED, JUST CONS UP SYMBOL
PUSHJ P,PURCOPY ;ELSE GET PURE COPY OF PNAME
JRST PSYCONS ;AND USE PURE CONSER
PNGNK1: SKIPGE LPNF ;CONS UP PNAME IF NECESSARY
PNGNK2: PUSHJ P,PNCONS
SYCONS: ;CONS UP A SYMBOL - PNAME LIST IS IN A
BAKPRO
SKIPN FFY ;IF SYMBOL FREELIST EMPTY, GO DO A GC
JRST SYCON1
SKIPN B,FFY2 ;IF SYMBOL BLOCK FREELIST EMPTY, MUST GC
JRST SYCON1
MOVEM A,SYMPNAME(B) ;PUT PNAME IN SYMBOL BLOCK
MOVE A,[SY.ONE,,SUNBOUND] ;INITIAL VALUE CELL IS SUNBOUND
XCTPRO
EXCH A,SYMVC(B) ;PUT IN SYMBOL BLOCK
MOVEM A,FFY2 ;CDR SYMBOL BLOCK FREELIST
SYCON2: MOVSI A,(B) ;INITIAL PROPERTY LIST IS NIL
EXCH A,@FFY ;CONS UP SYMBOL HEADER
EXCH A,FFY
NOPRO
POPJ P,
SPECPRO INTSYX
SYCON1: PUSHJ P,AGC
JRST SYCONS
;PURE SYMBOL CONSER
PSYCONS:
BAKPRO
AOSL B,NPFFY2 ;CONS UP A PURE SYMBOL BLOCK
NOPRO
SPECPRO INTSYQ
PUSHJ P,GTNPSG
ADD B,EPFFY2
AOS NPFFY2
SPECPRO INTSYP
MOVEM A,SYMPNAME(B)
MOVE A,[SY.ONE+SY.PUR,,SUNBOUND] ;SY.PUR BIT SAYS MAYBE READ-ONLY
MOVEM A,SYMVC(B)
BAKPRO
SKIPE FFY ;IF SYMBOL FREELIST EMPTY, GO DO A GC
JRST SYCON2
PUSHJ P,AGC
JRST SYCON2
NOPRO
PNCONS: PUSH FXP,T ;CONS A PNAME LIST OUT OF PNBUF
MOVEI A,NIL
2DIF [MOVEI C,(C)]1,PNBUF
PNG2: MOVE B,A
MOVE TT,PNBUF-1(C)
JSP T,FWCONS
PUSHJ P,CONS
SOJG C,PNG2
CPXTJ: JRST POPXTJ
;XCONS CONS CONS1 CONS3 $NCONS $XCONS LIST. %PDLNC %PDLXC %PDLC %XCONS %CONS %CONS1 %CONS3 %C2NS $C2NS
SUBTTL LIST SPACE CONSERS
;;; THIS SET OF CONSERS IS USED WITHIN THE LISP SYSTEM.
;;; ONLY A AND B ARE CLOBBERED, AND THE ARGUMENTS MUST NOT
;;; BE PDL QUANTITIES.
;;; FOR NCONS, SEE JUST BEFORE "ACONS"
;NCONS: TRZA B,-1 ;(NCONS A) = (CONS A NIL)
XCONS: EXCH B,A ;(XCONS A B) = (CONS B A)
CONS: HRL B,A
SPECPRO INTC2X
CONS1: SKIPN A,FFS ;SKIP UNLESS FREELIST EMPTY
JRST CONS3
EXCH B,(A) ;PUT POINTERS IN CELL, GET CDR OF FREELIST
XCTPRO
EXCH B,FFS ;CDR FREELIST, COPY OF CELL POINTER TO B
NOPRO ; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT)
POPJ P,
SPECPRO INTC2X
CONS3: HLR A,B ;DO THIS TO PROTECT POINTERS FROM GC
PUSHJ P,AGC ;PERFORM A GARBAGE COLLECTION
NOPRO
JRST CONS1 ;GO TRY AGAIN
;;; THIS SET OF CONSERS IS THE SET AVAILABLE TO INTERPRETED CODE.
;;; THEY MAKE SURE THAT PDL QUANTITIES DO NOT GET INTO LIST STRUCTURE.
$NCONS: MOVEI B,NIL ;SUBR 1
EXCH A,B
$XCONS: JSP T,PDLNMK ;SUBR 2
EXCH A,B
JSP T,PDLNMK
JRST CONS
LIST.: AOJG T,LIST.9 ;LSUBR (1 . N)
POP P,A ;(CONS A B C D) = (CONS A (CONS B (CONS C D)))
PUSH FXP,R ;THIS ROUTINE MUST SAVE R AS COMPILED CODE COUNTS ON IT
MOVE R,T ;LISTX3 WILL WANT COUNT IN R - ALSO SAVE OVER PDLNMK
JSP T,PDLNMK
PUSHJ FXP,LISTX3 ;LISTIFY ALL BUT LAST ARG,
POP FXP,R
POPJ P, ; WITH LAST ARG AS FINAL CDR
;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE.
;;; THE "CDR" MUST NOT BE A PDL QUANTITY; THE "CAR" IS PDLNMK'D.
%PDLNC: TRZA B,-1
%PDLXC: EXCH B,A
%PDLC: CAML A,NPDLL ;VERY FAST CHECK FOR A PDL NUMBER
CAMLE A,NPDLH
JRST %CONS
PUSH P,T ;IF PROBABLY A PDL NUMBER,
JSP T,PDLNM0 ; IT'S SO SLOW THAT THIS PART
; DOESN'T MATTER SO MUCH,
JRST CONS ; BLETCHEROUS IS IT IS
;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE.
;;; ARGUMENTS MUST NOT BE PDL QUANTITIES.
;;; THESE ARE SLIGHTLY FASTER, SINCE T IS USED FOR JSP.
;;; FOR %NCONS, SEE JUST BEFORE "ACONS"
;%NCONS: TRZA B,-1 ;(NCONS A) = (CONS A NIL)
%XCONS: EXCH B,A ;(XCONS A B) = (CONS B A)
%CONS: HRLI B,(A)
SPECPRO INTC2Y
%CONS1: SKIPN A,FFS ;SKIP UNLESS FREELIST EMPTY
JRST %CONS3
EXCH B,(A) ;PUT POINTERS IN CELL, GET CDR OF FREELIST
XCTPRO
EXCH B,FFS ;CDR FREELIST, COPY OF CELL POINTER TO B
NOPRO ; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT)
JRST (T)
SPECPRO INTC2Y
%CONS3: HLR A,B ;DO THIS TO PROTECT POINTERS FROM GC
PUSHJ P,AGC ;PERFORM A GARBAGE COLLECTION
NOPRO
JRST %CONS1 ;GO TRY AGAIN
;THIS ROUTINE IS FOR COMPILED CODE. IT DOES A PDLNMK CHECK ON BOTH ARGS
%C2NS: PUSH P,T ;ALLOW RETURN VIA PUSHJ
$C2NS: EXCH A,B ;WE CAN USE $XCONS, BUT IT WILL ALSO DO AN EXCH
JRST $XCONS
;FIX2 FIX1 FXCONS FIX1A FWCONS FLCONX FLOAT2 FLOAT1 FLCONS FPCONS
SUBTTL NUMBER CONSERS
FIX2: JSP T,IFIX ;FLONUM TO FIXNUM CONVERSION, FXCONS, POPJ
FIX1: POP P,T ;FXCONS, THEN POPJ
FXCONS: ;FIXNUM CONS - MAY UNIQUIZE
FIX1A: CAIGE TT,XHINUM ;IF WITHIN THE RANGE OF THE
CAMGE TT,[-XLONUM] ; BUILT-IN TABLE OF UNIQUE FIXNUMS,
JRST FWCONS ; THEN NEEDN'T DO A REAL CONS
MOVEI A,IN0(TT) ;JUST PROVIDE A POINTER INTO THE TABLE
JRST (T)
SPECPRO INTZAX
FWCONS: SKIPN A,FFX ;FULL WORD CONS - ALWAYS CONSES
JSP A,AGC4
EXCH TT,(A)
XCTPRO
EXCH TT,FFX
NOPRO
JRST (T)
FLCONX: AOJA T,FLCONS ;FLCONS WITH SKIP RETURN
FLOAT2: JSP T,IFLOAT ;FIXNUM TO FLONUM, FLCONS, POPJ
FLOAT1: POP P,T ;FLCONS, THEN POPJ
SPECPRO INTZAX
FLCONS: ;FLONUM CONS
FPCONS: SKIPN A,FFL
JSP A,AGC4
EXCH TT,(A)
XCTPRO
EXCH TT,FFL
NOPRO
JRST (T)
;DBL1 DBCONS DBCONS DBL1 CXCONX CMPL1 CXCONS CXCONS CMPL1 DUPL1 DXCONS DXCONS DUPL1
IFN DBFLAG,[
DBL1: POP P,T
SPECPRO INTZAX
DBCONS: HRRZS FFD ;DOUBLE PRECISION CONSER
SKIPN A,FFD
JSP A,AGC4
EXCH TT,(A)
XCTPRO
EXCH TT,FFD
NOPRO
MOVEM D,1(A)
JRST (T)
] ;END OF IFN DBFLAG
IFE DBFLAG,[
DBCONS: PUSH P,T
DBL1: MOVEI A,QDOUBLE ;ERROR IF DOUBLES NOT IMPLEMENTED
%FAC NUM1MS
] ;END OF IFE DBFLAG
IFN CXFLAG,[
CXCONX: AOJA T,CXCONS ;CXCONS WITH SKIP RETURN
CMPL1: POP P,T
SPECPRO INTZAX
CXCONS: HRRZS FFC ;COMPLEX NUMBER CONSER
SKIPN A,FFC
JSP A,AGC4
EXCH TT,(A)
XCTPRO
EXCH TT,FFC
NOPRO
MOVEM D,1(A)
JRST (T)
] ;END OF IFN CXFLAG
IFE CXFLAG,[
CXCONS: PUSH P,T
CMPL1: MOVEI A,QCOMPLEX ;ERROR IS COMPLEX NUMBERS NOT IMPLEMENTED
%FAC NUM1MS
] ;END OF IFE CXFLAG
IFN DXFLAG,[
DUPL1: POP P,T
SPECPRO INTZAX
DXCONS: HRRZS FFZ ;DOUBLE-PRECISION COMPLEX NUMBER CONSER
SKIPN A,FFZ
JSP A,AGC4
EXCH R,(A)
XCTPRO
EXCH R,FFZ
NOPRO
MOVEM F,1(A)
KA MOVEM TT,2(A)
KA MOVEM D,3(A)
KIKL DMOVEM TT,2(A)
JRST (T)
] ;END OF IFN DXFLAG
IFE DXFLAG,[
DXCONS: PUSH P,T
DUPL1: MOVEI A,QDUPLEX ;ERROR IF DUPLICES NOT IMPLEMENTED
%FAC NUM1MS
] ;END OF IFE DXFLAG
;%HUNK1 %HUNK2 %HUNK3 %HUNK4 %CXR %RPX CXR CXR2 RPLACX RPLX2 CXR30 CXR31 CXR3 CXR33 CXR34
SUBTTL HUNK PRIMITIVES - CXR, RPLACX, HUNK<N>, HUNK, HUNKIFY
IFE HNKLOG,[
%HUNK1:
%HUNK2:
%HUNK3:
%HUNK4:
%CXR:
%RPX: LERR [SIXBIT \NO HUNKS IN THIS LISP - HUNK/CXR/RPLACX!\]
] ;END OF IFE HNKLOG
IFN HNKLOG,[
CXR: JSP T,FXNV1 ;SUBR 2
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,CXR2
HLRZ A,(TT) ;ODD-NUMBERED COMPONENTS IN LEFT HALVES
POPJ P,
CXR2: HRRZ A,(TT) ;EVEN-NUMBERED COMPONENTS IN RIGHT HALVES
POPJ P,
RPLACX: JSP T,FXNV1 ;SUBR 3
SKIPE V.RSET
JSP F,CXR3 ;CHECK ARGS
CAML C,NPDLL
CAMLE C,NPDLH
JRST .+4
EXCH A,C
JSP T,PDLNMK ;SIGH - MUST PDLNMK THE DATUM
EXCH A,C
ROT TT,-1
ADDI TT,(B)
JUMPGE TT,RPLX2
HRLM C,(TT)
JRST BRETJ ;RETURN SECOND ARG
RPLX2: HRRM C,(TT)
JRST BRETJ
CXR30: TLNN T,$FS+VC ;A LIST CELL OR VALUE CELL IS OKAY
JRST CXR31 ; IF THE INDEX IS 0 OR 1
JUMPL TT,CXR33
CAIG TT,1
JRST (F)
CXR31: EXCH A,B
WTA [INVALID OR WRONG LENGTH HUNK!]
EXCH A,B
CXR3: MOVEI T,(B) ;CHECKING ROUTINE FOR CXR/RPLACX
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,HNK ;SECOND ARG MUST BE HUNK
JRST CXR30
MOVEI D,2
2DIF [LSH D,(T)]0,QHUNK0
CAMLE D,TT ;FIRST ARG MUST BE SMALLER THAN
JUMPGE TT,CXR34 ; LENGTH OF SECOND, YET NON-NEGATIVE
CXR33: WTA [BAD HUNK INDEX!]
JRST -3(F)
CXR34: MOVE D,TT ;EVERYTHING IS APPARENTLY OKAY
ROT D,-1
ADDI D,(B)
HRRZ T,(D) ;FETCH COMPONENT IN QUESTION
SKIPGE D
HLRZ T,(D)
CAIN T,-1 ;ERROR IF AN UNUSED COMPONENT
JRST CXR33
JRST (F)
;%CXR %CXR2 %RPX %RPX2 %HUNK1 %HNK2A %HUNK2 %HUNK3 %HNK4A %HUNK4
;;; IFN HNKLOG
;;; CXR ROUTINE FOR COMPILED CODE. HUNK IN A, INDEX IN TT.
%CXR: ROT TT,-1 ;QUICK ENTRY FOR COMPILED CALLS
ADDI TT,(A)
JUMPGE TT,%CXR2
HLRZ A,(TT)
JRST (T)
%CXR2: HRRZ A,(TT)
JRST (T)
;;; RPLACX ROUTINE FOR COMPILED CODE.
;;; HUNK IN A, DATUM IN B, INDEX IN TT.
;;; THE DATUM IS GUARANTEED NOT TO BE A PDL QUANTITY.
%RPX: ROT TT,-1 ;HUNK SUBSCRIPT IS PASSED IN TT
ADDI TT,(A)
JUMPGE TT,%RPX2
HRLM B,(TT)
JRST (T)
%RPX2: HRRM B,(TT)
JRST (T)
;;; %HUNK1, %HUNK2, %HUNK3, AND %HUNK4 ROUTINES FOR COMPILED CODE.
;;; THESE ALLOCATE HUNKS OF SIZE 1, 2, 3, OR 4 SUPER-QUICKLY.
;;; ARGUMENTS IN A, B, C, AR1, GUARANTEED NOT TO BE PDL QUANTITIES.
%HUNK1: SKIPN VMAKHUNK
JRST %NCONS
MOVEI B,(A) ;%HUNK1 IS %HUNK2, WITH ONE UNUSED COMPONENT,
MOVEI A,-1 ; BUT UNFORTUNATELY MUST SHUFFLE ARGS
JRST %HUNK2
%HNK2A: HRRZS FFH ;HUNK4 IS THE IMPORTANT CASE
PUSHJ P,AGC
BAKPRO
%HUNK2: SKIPN VMAKHUNK
JRST %CONS
SKIPG FFH
JRST %HNK2A
HRL B,A
EXCH B,@FFH
XCTPRO
EXCH B,FFH
EXCH A,B
NOPRO
JRST (T)
%HUNK3: MOVEI AR1,(C) ;HUNK3 IS JUST HUNK4, WITH ONE UNUSED COMPONENT,
MOVEI C,-1 ; BUT UNFORTUNATELY MUST SHUFFLE ARGS
JRST %HUNK4
%HNK4A: HRRZS FFH+1 ;HUNK4 IS THE IMPORTANT CASE
PUSHJ P,AGC
BAKPRO
%HUNK4: SKIPG FFH+1
JRST %HNK4A
HRL AR1,A
EXCH AR1,@FFH+1
XCTPRO
EXCH AR1,FFH+1
EXCH A,AR1
HRRZM B,1(A)
HRLM C,1(A)
NOPRO
JRST (T)
;HNKSZ0 HUNKSIZE HNKSZ1 HNKSZ3 HUNKP MHUNKE MAKHUNK MHUNK7 MHUNK6 MHUNK5 HUNK
;;; IFN HNKLOG
HNKSZ0: WTA [NOT A HUNK - HUNKSIZE!]
JRST HNKSZ1
HUNKSIZE: ;SUBR 1 - NCALLABLE
PUSH P,CFIX1
HNKSZ1: MOVEI T,(A)
LSH T,-SEGLOG
SKIPL T,ST(T)
JRST HNKSZ0
MOVEI TT,2
TLNE T,HNK
JRST .+4
SKIPN VMAKHUNK
POPJ P, ;RANDOM CONSES ARE OF SIZE 2
JRST HNKSZ0
MOVEI D,1
2DIF [LSHC TT,(T)]0,QHUNK0
ADDI D,-1(A)
HNKSZ3: SETCM R,(D) ;OTHERWISE CALCULATE LENGTH
TLNE R,-1
POPJ P,
TRNE R,-1
SOJA TT,CPOPJ
SUBI D,1
SUBI TT,2
JUMPG TT,HNKSZ3
.VALUE
HUNKP: LSH A,-SEGLOG ;SUBR 1
SKIPGE A,ST(A)
TLNN A,HNK
JRST FALSE
JRST TRUE
MHUNKE: WTA [MUST BE LIST OR FIXNUM - MAKHUNK!]
MAKHUNK: SKOTT A,FX ;SUBR 1
JRST MHUNK5
SKIPN TT,(A)
JRST FALSE
MOVE T,TT
PUSHJ P,ALHUNK ;INITIALIZED TO NIL
MHUNK7: LSHC T,-1 ;LEAVES THE "ODDP" BIT IN SIGN OF TT
HRLOI T,-1(T) ;SEE HAKMEM FOR THIS EQVI HAK
EQVI T,(A)
TLNN T,-1
JRST MHUNK6
SETZM (T)
AOBJN T,.-1
MHUNK6: SKIPGE TT
HLLZS (T)
POPJ P,
MHUNK5: JUMPGE TT,MHUNKE .SEE LS
JSP TT,AP2 ;STACK LIST ON PDL, -COUNT IN T
HUNK: MOVN TT,T ;LSUBR
AOJG T,FALSE ;CREATE HUNK BIG ENOUGH TO
MOVEI D,QHUNK ; HOLD ALL GIVEN ARGUMENTS,
CAILE TT,2←HNKLOG
SOJA T,WNALOSE
PUSHJ FXP,ALHNKL ; AND INSTALL THEM
POPJ P,
;ALHNKL ALHNLA ALHNLD ALHNLY ALHNLX ALHUNK ALHNKD ALHNKF
;;; IFN HNKLOG
;;; HUNK ALLOCATION ROUTINES
;;; MAKE A HUNK - (TT) HAS NUMBER OF ITEMS WANTED.
;;; THEN INSTALL THESE ITEMS FROM PDL BY POPPING OFF
ALHNKL: PUSH FXP,TT
PUSHJ P,ALHUNK ;CREATE A FRESH HUNK, AND INSTALL ARGS FROM PDL
MOVEI B,(A) ;SAVES C - ALSO USED BY FASLOAD
POP P,A .SEE LDLHNK
JSP T,PDLNMK ;CAN'T PUT PDL QUANTITY INTO A HUNK
HRROM A,(B) ;LAST ELEMENT GOES IN POSITION 0
SOSN TT,(FXP)
JRST ALHNLY
LSHC TT,-1 ;IN D, SIGN BIT ON ==> EVEN NUMBER OF ELEMENTS
MOVEI T,(B)
ADDI T,(TT)
EXCH D,T ;NOW IN D - LAST WORD INTO WHICH TO POP
JUMPGE T,ALHNLD
ALHNLA: POP P,A ;LOOP TO INSTALL ARGS IN HUNK
JSP T,PDLNMK
HRLM A,(D)
ALHNLD: SOJL TT,ALHNLX
POP P,A
JSP T,PDLNMK
HRRM A,(D)
SOJA D,ALHNLA
ALHNLY: SKIPN VMAKHUNK
HRLZS (B)
ALHNLX: POPI FXP,1
EXCH A,B
POPJ FXP,
;;; ALLOCATE A HUNK OF SIZE INDICATED IN (TT)
;;; AND INITIALIZE TO THE "UNUSED" POINTER (#777777)
ALHUNK: JUMPLE TT,ALHNKE
CAILE TT,2←HNKLOG ;MUST PRESERVE T
JRST ALHNKE
SUBI TT,1
JFFO TT,ALHNKD ;SELECT CONSER FOR CORRECT SIZE HUNK
JRST ALHNKF
ALHNKD: JRST ALHNKF-35.(D) ;DISPATCH TO INDIVIDUAL HUNK CONSERS BELOW
RADIX 10.
REPEAT HNKLOG, JRST CONC ALHNK,\<HNKLOG-.RPCNT>
RADIX 8
ALHNKF: SKIPE VMAKHUNK ;1 OR 2 THINGS - TEST FOR USE OF CONS
JRST ALHNK0
JRA A,ACONS
;;; HUNK<index> IS THE CONSER FOR HUNKS OF SIZE 2↑<index> WORDS.
;;; index no.: 0 1 2 3 4 5 6 7 8 9
;;; no. words: 1 2 4 8 16 32 64 128 256 512
;;; no. items: 2 4 8 16 32 64 128 256 512 1024
;;; WARNING! THESE CONSERS MUST PRESERVE T
.SEE MHUNK7
REPEAT HNKLOG+1,[
SPECPRO INTZAX
RADIX 10.
CONC GHNK,\.RPCNT,:
HRRZS FFH+.RPCNT ;FLUSH SIGN BIT - NEED A HUNK NOW
SKIPN A,FFH+.RPCNT ;INITIATE GC DUE TO HUNKS
JSP A,AGC4
CONC ALHNK,\.RPCNT,: ;VARIOUS HUNK CONSERS: HUNK0, HUNK1, ...
SKIPG A,FFH+.RPCNT
JRST CONC GHNK,\.RPCNT
HRRZ TT,(A)
RADIX 8
XCTPRO
MOVEM TT,FFH+.RPCNT
SETOM (A) ;MUST FILL IN COMPONENTS WITH THE "UNUSED" POINTER
IFLE .RPCNT-2, REPEAT <1←.RPCNT>-1, SETOM .RPCNT+1(A)
IFG .RPCNT-2,[
MOVEI D,1(A)
HRLI D,(A)
BLT D,<1←.RPCNT>-1(A)
]
NOPRO
POPJ P,
] ;END OF REPEAT HNKLOG
] ;END OF IFN HNKLOG
;ATOM LATOM SPATOM SPAT1 PRPLSE PLIST PRPNIL RPLIZ SETPLIST RPSNIL STENT
SUBTTL ATOM, PLIST, SETPLIST, ASSOC AND FRIENDS
ATOM: LSH A,-SEGLOG ;CAN DO LSH HERE BECAUSE DON'T NEED ARG
SKIPGE ST(A) ;FALSE ONLY FOR NON-ATOMIC
TDZA A,A ; FREE-STORAGE POINTERS
MOVEI A,TRUTH
POPJ P,
LATOM: ;SKIP IF EQ TEST IS SUFFICIENT FOR EQUALITY
SPATOM: JUMPE A,1(T) ;SKIP IF NIL (WHICH IS SYMBOL)
SPAT1: SKOTT A,SY ;LEAVES TYPE BITS IN TT
JRST (T)
JRST 1(T)
PRPLSE: JUMPE A,PRPNIL
JRST FALSE
PLIST: SKOTT A,SY+LS ;SUBR 1 - FETCH PROPERTY LIST
JRST PRPLSE
HRRZ A,(A)
POPJ P,
PRPNIL: HRRZ A,NILPROPS ;SPECIAL HACK FOR NIL
POPJ P,
RPLIZ: JUMPE A,RPSNIL
%WTA NASER
SETPLIST:
SKOTT A,SY+LS ;SUBR 2 - SET PROPERTY LIST
JRST RPLIZ
HRRM B,(A)
MOVE A,B
POPJ P,
RPSNIL: HRRM B,NILPROPS ;SPECIAL HACK FOR NIL
POPJ P,
STENT: MOVEI TT,(A) ;GET ST ENTRY FOR A IN TT
LSH TT,-SEGLOG ;FOR USE WHERE SPACE MORE IMPORTANT THAN TIME
MOVE TT,ST(TT)
JRST (T)
;SASSQ SASSOC ASSOC ASSQ FALSE IASSOC IASSQ IASSC0 IASSC3 IASSC7 IASSCX IASSC4 IASLOS IASSQ0 IASSQF IASWIN
SASSQ: SKIPA T,ASSQ ;[IASSQ]
SASSOC: MOVEI T,IASSOC
PUSHJ P,(T)
CALLF 0,(C)
POPJ P,
ASSOC: SKIPA T,SASSOC ;[IASSOC]
ASSQ: MOVEI T,IASSQ
PUSHJ P,(T) ;.SEE SSGCP1 - MUST PRESERVE R
FALSE: MOVEI A,NIL
POPJ P,
IASSOC: MOVEI F,TRUTH ;INTERNAL "ASSOC"
JSP T,LATOM
JRST IASSC0
IASSQ: MOVEI F,NIL
SKIPN V.RSET
JRST IASSQF ;FAST VERSION OF ASSQ WITH NO CHECKING
IASSC0: SAVE B F A B ;ASSOC LOOP WITH CHECKING
MOVE TT,B
JRST IASSC7
IASSC3: HLRZ TT,T
MOVEM TT,(P) ;(P) HOLDS SUCCESSIVE TAILS OF LIST
IASSC7: SKOTT TT,LS
JRST IASSC4
MOVS T,@(P)
SKOTT T,LS
JRST IASSC3 ; "NIL" ENTRIES GET BYPASSED HERE
HLRZ B,(T)
CAMN B,-1(P) ;-1(P) HOLDS ITEM BEING SOUGHT
JRST IASSCX
SKIPN -2(P) ;-2(P) FLAG = () FOR ASSQ, NON-() FOR ASSOC
JRST IASSC3
MOVE A,-1(P)
PUSHJ P,EQUAL
MOVS T,@(P)
JUMPE A,IASSC3
IASSCX: POP P,B
POPI P,3
JRST IASWIN
IASSC4: SKIPN (P)
JRST IASLOS
JSP T,MEMQER
JRST IASSC3
IASLOS: POPI P,4
POPJ P,
IASSQ0: HLRZ B,T
IASSQF: JUMPE B,CPOPJ ;FAST VERSION OF ASSQ WITH NO CHECKING
MOVS T,(B) ; MUST PRESERVE AR2A - SEE FASLAP
HLRZ TT,(T) ; NOTE - MUST NOT USE OTHER THAN A, B, T, TT
CAIE A,(TT) ; BECAUSE OF ASSQ'S FOR READ CHAR MACROS
JRST IASSQ0
TRNN T,-1 ;SPURIOUS MATCH OF "()" WITH NULL SLOT
JRST IASSQ0 ; E.G. ((A . 1) () (() . 5))
IASWIN: POP P,T
HLRZ A,(B) ;BUT EXIT BY SKIPPING IF WIN, LEAVING FINAL
JRST 1(T) ; TAIL IN (B) - .SEE SSGCP1
;GET BOUND1 GET3 GET0 GET1 SARGET ARGET ARGET1 PNGET PNGT1 PNGT0
SUBTTL GET, GETL, PUTPROP, REMPROP FUNCTIONS
GET: SKOTT A,LS+SY
JRST GET3
CAIN B,QVALUE ;CROCK CROCK CROCK!!!!!
TLNN TT,SY
JRST GET1
JUMPE A,BOUND1
HLRZ B,(A) ;MORE CROCK MORE CROCK MORE CROCK!!!!!!
HRRZ A,(B) ; (BUT LAP DEPENDS ON IT...)
CAIN A,SUNBOUND
SETZ A,
POPJ P,
BOUND1: MOVEI A,VNIL
POPJ P,
GET3: JUMPN A,FALSE
MOVEI A,NILPROPS
CAIE B,QVALUE
JRST GET1
MOVEI A,VNIL
POPJ P,
GET0: HRRZ A,(TT) ;USES ONLY A,B,TT
JUMPE A,CPOPJ
GET1: HRRZ TT,(A) ;MUST PRESERVE B, C, AR1, T, D
JUMPE TT,FALSE ;(SEE EVAL AT EV3, MKNAM3, .REARRAY, AND ARRY1)
HLRZ A,(TT) ;ALSO PRESERVE R, SEE UUOH1
CAIE A,(B) ;ALSO AR2A AND F, SEE FASLOAD
JRST GET0
HRRZ TT,(TT)
HLRZ A,(TT)
POPJ P,
SARGET: MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,SA
POPJ P,
ARGET: JSP T,SPATOM ;GET ARRAY PROPERTY FROM ATOM
JSP T,PNGE1
ARGET1: MOVEI B,QARRAY
JRST GET1
PNGET: JSP T,SPATOM ;INTERNAL SUBROUTINE -GET PNAME PROP FROM ATOM
PNGT1: JSP T,PNGE
PNGT0: SKIPN A ;SAVES B
SKIPA TT,[$$$NIL]
HLRZ TT,(A) ;MUST DO IT INTO TT SO AS TO HAVE
HRRZ A,1(TT) ; CONTINUOUS GC PROTECTION
POPJ P,
.SEE CRSR40
;GETL GETLA GETL5 GETL1 GETL0 GETL1A GETL4
GETL: SKIPN V.RSET
JRST GETL5
SKOTT B,LS
JUMPN B,GETLE
GETLA: MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,LS+SY
JRST GETL1
JUMPN A,FALSE ;FALL INTO GETL5 - WON'T HURT
GETL5: JUMPN A,GETL1
MOVEI A,NILPROPS
GETL1: JUMPE B,FALSE ;FLUSH DEGENERATE CASE OF NO PROPS
JRST GETL1A
GETL0: HRRZ A,(A) ;USES A,B,C,T,TT
JUMPE A,CPOPJ
GETL1A: HRRZ A,(A) ;GET NEXT OFF PROPERTY LIST
JUMPE A,CPOPJ
HLRZ T,(A)
MOVE C,B
GETL4: HLRZ TT,(C) ;MEMQ IT DOWN LIST OF PROPS
CAIN T,(TT)
POPJ P,
HRRZ C,(C)
JUMPN C,GETL4
JRST GETL0
;PUTPROP CSET0C CSET0Q CSET0 CSET0A BRETJ SPROG2 CSET7 CSET2 CSET2A $CADR $CAR C$CAR CSET4 CSET4A
;;; ARGUMENTS ARE A SYMBOL, A VALUE, AND AN INDICATOR.
;;; THE INDICATOR MUST NOT BE A PDL QUANTITY (RECALL THAT THE
;;; EQNESS OF SUCH QUANTITIES IS UNDEFINED IN THE LANGUAGE ANYWAY).
;;; THE VALUE IS PDLNMK'D IF NECESSARY. THE SYMBOL MAY BE A LIST
;;; (KNOWN AS A "DISEMBODIED PROPERTY LIST"; THE CDR IS THE PLIST).
;;; IF THE PROPERTY ALREADY EXISTS, THE NEW VALUE IS INSTALLED THERE.
;;; OTHERWISE A NEW PROPERTY IS INSTALLED AT THE FRONT OF THE
;;; PROPERTY LIST. IF THE PROPERTY ALREADY EXISTS IN A PORTION
;;; OF THE PROPERTY LIST THAT IS PURE, ENOUGH OF THE PURE PART
;;; IS COPIED AS IMPURE LIST STRUCTURE TO PERMIT THE PUTPROP.
;;; IF THE VALUE OF *PURE IS NON-NIL, THEN THE VALUE IS PURCOPY'D
;;; AND THE NEW PROPERTY LIST CELLS, IF ANY, ARE PURE-CONSED.
PUTPROP:
SKOTT A,LS+SY ;LISTS AND SYMBOLS ARE OKAY
JRST CSET7
CSET0C: CAML B,NPDLL ;MAKE A QUICK TEST ON THE SECOND ARGUMENT
CAML B,NPDLH ;SHIP-OF-THE-DESERT TEST (TWO CAML'S)
JRST CSET0Q
EXCH B,A ;LOSE - MUST PDLNMK THE VALUE
JSP T,PDLNMK
EXCH B,A
CSET0Q: MOVEI T,(A)
CSET0: HRRZ T,(T) ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
JUMPE T,CSET2 ;SEARCH FOR AN EXISTING PROPERTY
HLRZ TT,(T)
HRRZ T,(T)
CAIE TT,(C)
JRST CSET0
CSET0A: ;IF PROPERTY FOUND, CLOBBER IN
PURTRAP CSET4,T,HRLM B,(T)
BRETJ:
SPROG2: MOVEI A,(B) ;RETURN VALUE
POPJ P,
CSET7: JUMPN A,PROPER
MOVEI A,NILPROPS
JRST CSET0C
CSET2: PUSH P,A ;DOESN'T HAVE SUCH A PROPERTY, SO CONS ONE UP
SKIPE V.PURE
JRST CSETP1 ;MAYBE WANT TO PURE-CONS
CSET2A: HRRZ A,(A) ;PLAIN VANILLA CONSES
PUSHJ P,XCONS
HRRZ B,C
JSP T,%PDLXC ;IN CASE SOMEONE TRIES TO USE A PDLNUM
POP P,C
HRRM A,(C) ;SETPLIST TO NEW THING
$CADR: HRRZ A,(A) ;RETURN VALUE (I.E. GET IT BACK)
$CAR: HLRZ A,(A)
C$CAR: POPJ P,$CAR
CSET4: PUSH P,A ;FOOL PROPERTY IS IN A PURE PAGE
PUSH P,B
MOVEI T,(A)
CSET4A: HRRZ TT,(T) ;COPY ENOUGH OF THE PROPERTY LIST
PUSHJ P,CSET4C ; TO PERMIT THE PUTPROP
HLRZ A,(TT)
CAIE A,(C)
JRST CSET4A
POP P,B
POP P,A
JRST CSET0A ;NOW TRY IT
;REMPROP REMP0 REMP1 REMP20 REMP7 CSET4C REMP3 REMP3A
REMPROP: ;SUBR 2 - REMOVE PROPERTY FROM ATOMIC SYMBOL
SKOTT A,LS+SY
JRST REMP7 ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT
REMP0: SKIPA D,A ;SAVE C, AR2A - SEE DEFPROP AND DEFUN
REMP1: HRRZ D,(T)
HRRZ T,(D)
JUMPE T,FALSE
MOVS TT,(T)
CAIE B,(TT)
JRST REMP1
HLRZ T,TT
REMP20: HRRZ TT,(T) ;A IS GC-PROTECTING THE ATOM
PURTRAP REMP3,D, HRRM TT,(D)
MOVEI A,(T)
POPJ P,
REMP7: JUMPN A,RMPER0
MOVEI A,NILPROPS
JRST REMP0
CSET4C: PUSHJ P,.+1 ;HAIRY WAY TO DO A DOUBLE COPY!
HRRZ A,(T)
MOVE B,(A)
PUSHJ P,CONS1
HRRM A,(T)
MOVEI T,(A)
POPJ P,
REMP3: PUSH P,A ;COME HERE ON PURE PAGE TRAP
PUSH P,B ;A ON PDL GC PROTECTS ATOM
MOVEI T,(A)
REMP3A: PUSHJ P,CSET4C ;COPY ENOUGH OF PROPERTY LIST
HRRZ TT,(T) ; TO DO REMPROP
HLRZ A,(TT)
CAME A,(P)
JRST REMP3A
HRRZ A,(TT)
HRRZ TT,(A)
HRRM TT,(T)
JRST POP2J
;NOTNOT NOT $NULL TRUE CNOT LAST LAST5 LAST4 LLASTCK LASTCK LAST1 LAST2 BOUNDP $RUNTIME RNTM1
SUBTTL NOT, NULL, LAST, BOUNDP, RUNTIME
NOTNOT: JUMPE A,CPOPJ ;REPLACES A NON-NIL VALUE BY T
JRST TRUE
NOT:
$NULL: JUMPN A,FALSE
TRUE: MOVEI A,TRUTH
CNOT: POPJ P,NOT
LAST: PUSHJ P,LLASTCK ;SUBR 1 - GET LAST CONS OF A LIST
JRST LAST4
LAST5: MOVE A,D
POPJ P,
LAST4: CAIE F,-1
JRST LAST5 ; (A B C ... . Z) CASE
SKOTTN A,LS ;SO WE TOOK NO CDRS!
JRST LAST5 ; (A . Z) CASE
HRRZ TT,C2 ;FOO! ALLOW RANDOM PTS TO PDL, FOR SAKE
CAILE A,(TT) ; OF THAT KLUDGEY CODE OUTPUT BY THE
CAILE A,(P) ; COMPLR FOR MAPCAN ETC.
JRST LASTER
SKIPN TT,(A)
POPJ P,
MOVEI A,(TT)
JRST LAST
LLASTCK: MOVEI F,-1 ;"LONG" LAST CHECK
; RETURNS <262143.-<NO. OF CDRS TAKEN>> IN F
; MUST PRESERVE T,R. SEE APPEND, REVERSE, NTHCDR
LASTCK: SKIPN D,A ;SKIP RETURN ON NORMAL-FORM LIST
JRST POPJ1 ; LEAVES PTR TO LAST NODE IN D,
SKOTT D,LS ;() IS OK, AND IS ITS OWN "LASTNODE"
POPJ P, ; BUT OTHER ATOMS LOSE
JUMPLE F,POPJ1 ; LIMITED TO (F) CDRS
LAST1: HRRZ TT,(D)
SKOTT TT,LS
JRST LAST2
HRRZ D,(D)
SOJG F,LAST1
JRST POPJ1
LAST2: HRRZ TT,(D)
JUMPE TT,POPJ1
POPJ P, ;ENDED WITH NON-NULL ATOM
BOUNDP: JUMPE A,TRUE ;SUBR 1
JSP T,SPATOM ;TRUE IFF THE SYMBOL ARGUMENT IS BOUND
JSP T,PNGE1 ;ERROR FOR NON-SYMBOLS
HLRZ T,(A) ;GET VALUE CELL
HRRZ A,(T) ;DO IT INTO T TO PROTECT FROM GC
HRRZ T,(A)
CAIN T,QUNBOUND
TDZA A,A
MOVEI A,TRUTH
POPJ P,
;;; RETURN RUNTIME AS A FIXNUM IN MICROSECOND
;;; UNITS (NOT NECESSARILY THAT ACCURATE THOUGH).
$RUNTIME:
PUSH P,CFIX1 ;SUBR 0 NCALLABLE
IT$ .SUSET [.RRUNT,,TT] ;RUNTIME IN 4-MICROSECOND UNITS
10$ SETZ TT,
10$ RUNTIM TT, ;RUNTIME IN MILLISECONDS
IFN D20,[
LOCKI ;MUST LOCKI OVER ALL JSYS'S
MOVEI 1,.FHSLF ;GET RUNTIME FOR SELF
RUNTM
MOVE TT,1 ;RUNTIME IN MILLISECONDS
SETZB 1,3 ;1 AND 3 HAVE DANGEROUS CRUD
UNLOCKI
] ;END OF IFN D20
RNTM1: ;CONVERT NUMBER FROM INTERNAL UNITS TO USECS
IT$ LSH TT,2
IT% IMULI TT,1000.
POPJ P, ;ANSWER IN MICROSECONDS
;$TIME TIME3 TIME8 ZZZ ZZZ
SUBTTL TIME FUNCTION
;;; RETURN A TIME STANDARD AS A FLONUM IN SECONDS.
;;; WE ENDEAVOR TO MAKE THIS INCREASE MONOTONICALLY AND TO MEASURE
;;; THE PASSAGE OF REAL TIME. IN PRACTICE, WE MAY NOT MEASURE
;;; REAL TIME WHILE THE TIME-SHARING SYSTEM IS TEMPORARILY STOPPED,
;;; AND WE PERMIT A GLITCH (RESET TO 0) AT MIDNIGHT OF EACH DECEMBER 31.
$TIME: PUSH P,CFLOAT1 ;SUBR 0 NCALLABLE
IFN ITS,[
.RDTIME TT, ;GET AMOUNT OF TIME SYSTEM HAS BEEN UP
; CAMGE TT,[30.*3600.*24.*28.] ;FOUR WEEKS OF 1/30 SEC TICS
; JRST .+3
; SUB TT,[30.*3600.*24.*28.]
; JRST .-3
JSP T,IFLOAT
FDVRI TT,(30.0)
] ;END OF IFN ITS
IFN D10,[
IFE SAIL,[
MOVE T,[%CNDTM] ;INTERNAL DATE/TIME STANDARD,
GETTAB T, ; AS DATE,,FRACTION OF DAY
JRST TIME3 ; 1-ORIGINED ON NOVEMBER 18, 1858
ADD T,[2*365.+1-43.,,] ;ALTER TO 0-ORIGIN ON JANUARY 1,1856
IDIV T,[365.*4+1,,] ;GET THIS MOD A FOUR-YEAR INTERVAL
JSP T,IFLOAT
FMPR T,[.OP <FSC -22>,86400.0,0] ;CONVERT TO SECONDS
POPJ P,
TIME3: MSTIME TT, ;THIS PRODUCES GLITCHES AT MIDNIGHT
JSP T,IFLOAT
FDVRI TT,(1000.0)
] ;END OF IFE SAIL
IFN SAIL,[
ACCTIM TT,
HLRZ D,TT
IDIVI D,12.*31. ;YEAR-1964 IN D
IDIVI R,31. ;MONTH-1 IN R, DAY-1 IN F
ADD F,TIME8(R) ;ADD IN NUMBER OF DAYS PRECEDING CURRENT MONTH
TLNN D,3 ;SKIP IF NOT LEAP YEAR
CAIL R,2 ;SKIP IF JANUARY OR FEBRUARY
SUBI F,1 ;ADJUST FOR CRETINOUS LEAP YEARS
IMULI F,24.*3600. ;CONVERT TO SECONDS FROM LAST MIDNIGHT TO MIDNIGHT LAST DEC 31
TLZ TT,-1
ADD TT,F ;ADD IN SECONDS SINCE MIDNIGHT LAST
JSP T,IFLOAT
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
LOCKI ;MUST LOCKI AROUND THE JSYS
TIME ;GET TIME SINCE SYSTEM LAST RESTARTED IN MSECS
MOVE TT,1
SETZ 1, ;ZERO CRUD
UNLOCKI
JSP T,IFLOAT
FDVRI TT,(1000.0) ;CONVERT TO SECONDS
] ;END OF IFN D20
POPJ P,
IFN SAIL,[
TIME8:
ZZZ==1 ;WILL SUBTRACT THIS 1 BACK EXCEPT FOR AFTER FEB 29'S
IRP X,,[31.,28.,31.,30.,31.,30.,31.,31.,30.,31.,30.,31.]
ZZZ
ZZZ==ZZZ+X
TERMIN
IFN ZZZ-366., WARN [TABLE OF CUMULATIVE DAYS IN MONTHS LOSES]
EXPUNGE ZZZ
] ;END OF IFN SAIL
;EQUAL EQUAL0 EQUAL1 EQLLST EQLTBL EQLNM4 EQLNM2 EQLNUM EQLOSE EQLBIG EQLHNK EQLHN1 EQLHN2
SUBTTL EQUAL FUNCTION
EQUAL: CAIN A,(B) ;EQ THINGS ARE EQUAL
JRST TRUE ; .SEE ASSOC - MUST PRESERVE F
MOVEM P,EQLP
PUSHJ P,EQUAL1 ;EQUAL1 ACTUALLY RETURNS ONLY IF EQUAL
JRST TRUE
EQUAL0: CAIN A,(B) ;EQ THINGS ARE EQUAL
POPJ P,
EQUAL1: MOVEI T,(A)
MOVEI TT,(B)
ROTC T,-SEGLOG ;GET TYPES OF ARGS
HRRZ T,ST(T)
MOVE TT,ST(TT)
CAIN T,(TT) ;MUST HAVE SAME TYPE TO BE EQUAL
2DIF JRST @(T),EQLTBL,QLIST .SEE STDISP
IFN HNKLOG,[
SKIPN VHUNKP
TLNN TT,LS
] ;END OF IFN HNKLOG
JRST EQLOSE
IFN HNKLOG,[
SKOTT A,LS ;IF VHUNKP CONTAINS NIL, THEN WANT TO
JRST EQLOSE ; TREAT ALL HUNKS AS IF THEY WERE LIST CELLS
] ;END OF IFN HNKLOG
EQLLST: PUSH P,(A)
PUSH P,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSHJ P,EQUAL0 ;COMPARE CARS
HRRZ A,-1(P)
HRRZ B,0(P)
SUB P,R70+2
JRST EQUAL0 ;COMPARE CDRS
EQLTBL: EQLLST ;LIST
EQLNUM ;FIXNUM
EQLNUM ;FLONUM
DB$ EQLNM2 ;DOUBLE
CX$ EQLNM2 ;COMPLEX
DX$ EQLNM4 ;DUPLEX
BG$ EQLBIG ;BIGNUM
EQLOSE ;PNAME ATOMS MUST BE EQ TO BE EQUAL
HN$ REPEAT HNKLOG+1, EQLHNK ;HUNKS REQUIRE RECURSION LIKE LISTS
EQLOSE ;RANDOMS AND NIL MUST BE EQ TO BE EQUAL
EQLOSE ;ARRAY POINTERS MUST BE EQ TO BE EQUAL
IFN .-EQLTBL-NTYPES, WARN [WRONG LENGTH TABLE]
IFN DXFLAG,[
EQLNM4:
KA MOVE T,2(A)
KA MOVE TT,3(A)
KIKL DMOVE T,2(A)
CAMN T,2(B)
CAME TT,3(B)
JRST EQLOSE
] ;END OF IFN DXFLAG
IFN DBFLAG+CXFLAG,[
EQLNM2: MOVE T,1(A)
CAME T,1(B)
JRST EQLOSE
] ;END OF IFN DBFLAG+CXFLAG
EQLNUM: MOVE T,(A)
CAMN T,(B) ;COMPARE VALUES OF NUMBERS
POPJ P,
EQLOSE: MOVE P,EQLP ;THE ULTIMATE FALSITY - ESCAPE BACK
JRST FALSE ; TO TOP LEVEL OF ENTRY TO EQUAL WITH FALSE
IFN BIGNUM,[
EQLBIG: HLRZ T,(A)
HLRZ TT,(B)
CAIE T,(TT) ;EQUAL BIGNUMS HAVE EQ SIGNS
JRST EQLOSE ; AND CDRS ARE EQUAL LISTS OF FIXNUMS
HRRZ A,(A) ;CHECK ONLY EQUAL CDRS
HRRZ B,(B)
JRST EQUAL0
] ;END OF IFN BIGNUM
IFN HNKLOG,[
EQLHNK: SKIPN VHUNKP
JRST EQLLST
PUSH P,A
PUSH P,B
MOVNI T,1
2DIF [LSH T,(TT)]0,QHUNK0 ;REALLY SHOULD BE ASH, BUT LSH IS FASTER ON KL10
HRLI B,(T)
PUSH P,A
PUSH P,B
EQLHN1: HLRZ A,@-1(P)
HRRZ B,(P)
HLRZ B,(B)
PUSHJ P,EQUAL0
HRRZ A,@-1(P)
HRRZ B,(P)
HRRZ B,(B)
PUSHJ P,EQUAL0
MOVE T,(P)
AOBJP T,EQLHN2
MOVEM T,(P)
AOS -1(P)
JRST EQLHN1
EQLHN2: SUB P,R70+4
POPJ P,
] ;END OF IFN HNKLOG
;NCONC APPEND APP2 APP3 .NCONC .NCNC1 .NCNC2 .NCNC3 .APPEND APP1 AR1RETJ SUBS4 REVERSE REV1 APRVCK REV4 NREVERSE NRECONC NREV1
SUBTTL NCONC, *NCONC, APPEND, *APPEND, REVERSE, NREVERSE, NRECONC
NCONC: TDZA R,R ;LSUBR - DESTRUCTIVELY CATENATE LISTS
APPEND: MOVEI R,.APPEND-.NCONC ;LSUBR - CATENATE BY COPYING
JUMPE T,FALSE
POP P,B
APP2: AOJE T,BRETJ
POP P,A
JUMPE A,APP2
SKIPE V.RSET
PUSHJ P,APRVCK
APP3: PUSHJ P,.NCONC+1(R) ;FIRST INST OF .NCONC IS "JUMPE A,BRETJ"
MOVE B,A
JRST APP2
.NCONC: JUMPE A,BRETJ .SEE APP3
.NCNC1: MOVEI TT,(A) ;SUBR 2 (*NCONC)
.NCNC2: HRRZ D,(TT)
JUMPE D,.NCNC3
HRRZ TT,(D)
JUMPN TT,.NCNC2
HRRM B,(D)
POPJ P,
.NCNC3: HRRM B,(TT)
POPJ P,
.APPEND: JUMPE A,BRETJ ;SUBR 2 (*APPEND)
MOVEI C,AR1 ;FIRST INST MUST BE JUMPE A,BRETJ
MOVE AR2A,A ;MUST SAVE T,D - SEE MAKOBLIST
APP1: HLRZ A,(AR2A)
PUSHJ P,CONS
HRRZ B,(A)
HRRM A,(C)
MOVE C,A
HRRZ AR2A,(AR2A)
JUMPN AR2A,APP1
AR1RETJ:
SUBS4: MOVEI A,(AR1)
POPJ P,
REVERSE: SKIPE V.RSET ;SUBR 1 - USES A,B,C,T,F
PUSHJ P,APRVCK
MOVEI C,(A)
MOVEI A,NIL ;REVERSES A LIST BY CONSING UP A COPY
REV1: JUMPE C,CPOPJ ; OF THE TOP LEVEL IN REVERSE ORDER
HLRZ B,(C)
PUSHJ P,XCONS
HRRZ C,(C)
JRST REV1
APRVCK: PUSHJ P,SAVX3 ;APPEND/REVERSE ARGUMENT CHECKING
REV4: PUSHJ P,LLASTCK ;MUST SAVE TT,D,R FOR MANY PLACES WHICH
JRST REVER ; CALL REVERSE/NREVERSE
JRST RSTX3
NREVERSE: MOVEI B,NIL ;SUBR 1 - REVERSE A LIST USING RPLACD'S
NRECONC: JUMPE A,BRETJ ;SUBR 2 - (NRECONC X Y)=(NCONC (NREVERSE X) Y)
SKIPE V.RSET ; - USES A,B,C,T,F
PUSHJ P,APRVCK
NREV1: HRRZ C,(A) ;ONLY 3 INSTRUCTIONS PER CELL! ZOOM!
HRRM B,(A)
JUMPE C,CPOPJ
HRRZ B,(C)
HRRM A,(C)
JUMPE B,CRETJ
HRRZ A,(B)
HRRM C,(B)
JUMPN A,NREV1
JRST BRETJ
;GENSYM GENSY0 GENSY2 GENSY3 GENSY1 GENSY7 GENSY6 GENSY5
SUBTTL GENSYM FUNCTION
GENSYM: JUMPN T,GENSY1
GENSY0: MOVE TT,[010700,,GNUM] ;STANDARD GENSYMER
MOVEI B,"0 ;WILL INCREMENT NUMERICAL PART
GENSY2: LDB T,TT ; AND GIVE OUT GENSYMED ATOM
AOS T
DPB T,TT
CAIG T,"9
JRST GENSY3
DPB B,TT
ADD TT,[070000,,0]
CAMGE TT,[350000,,]
JRST GENSY2
GENSY3: MOVE TT,GNUM
MOVEM TT,PNBUF
MOVEI C,PNBUF
JRST PNGNK2
GENSY1: MOVEI D,QGENSYM
AOJN T,S1WNALOSE
GENSY7: POP P,A
SKOTT A,FX
JRST GENSY5
MOVE TT,(A)
JUMPL TT,GENSY8
MOVE T,[010700,,GNUM]
GENSY6: IDIVI TT,10. ;INSTALL 4 DECIMAL DIGITS
ADDI D,"0 ; IN GENSYM COUNTER
DPB D,T
ADD T,[070000,,0]
CAMGE T,[350000,,]
JRST GENSY6
JRST GENSY3
GENSY5: TLNN TT,SY
JUMPN A,GENSY8
JSP T,CHNV1D
DPB TT,[350700,,GNUM]
JRST GENSY0
;MEMBER SMEMBER SMEMQ MEMQ2 MEMQ3 MEMQ4 MEMBR MEMB2 MEMB3 AR2ARETJ MEMB4 SUBST SUBS0A SUBS1 CRETJ SPROG3 SUBS2 SUBS3
SUBTTL MEMBER, MEMQ, SUBST, DELQ, DELETE, *DELQ, *DELETE
MEMBER: ;USES A,B,AR1,AR2A,T,TT
SMEMBER:: MOVEI AR1,(A) ; FOR BENEFIT OF DELETE
MOVEI AR2A,(B)
JSP T,LATOM
JRST MEMBR
SMEMQ: SETZM MEMV ;USES A,B,T,MUST PRESERVE AR1,AR2A;SEE GTSPC3
PUSH P,B
MEMQ2: SKOTT B,LS
JRST MEMQ4
HLRZ T,(B)
CAMN A,T
JRST MEMQ3
HRRM B,MEMV
HRRZ B,(B)
JRST MEMQ2
MEMQ3: POPI P,1
JRST SPROG2
MEMQ4: JUMPE B,MEMQ3
JSP T,MEMQER
JRST MEMQ2
MEMBR: SETZM MEMV
PUSH P,B
MEMB2: SKOTT AR2A,LS
JRST MEMB4
MOVE A,AR1
HLRZ B,(AR2A)
PUSHJ P,EQUAL
JUMPN A,MEMB3
HRRM AR2A,MEMV
HRRZ AR2A,(AR2A)
JRST MEMB2
MEMB3: POPI P,1
AR2ARETJ:
MOVEI A,(AR2A)
POPJ P,
MEMB4: JUMPE AR2A,MEMB3
JSP T,MEMQER
MOVE AR2A,B
JRST MEMB2
;;; SUBSTITUTE A FOR EQUAL OCCURRENCES OF B IN C.
SUBST: JSP T,PDLNMK ;SUBR 3
EXCH A,C
JSP T,PDLNMK
EXCH A,C
SKIPA AR1,A
SUBS0A: SKIPA A,AR1
SKIPA AR2A,B
MOVE B,AR2A
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,AR1RETJ
SUBS1: MOVE A,C
PUSHJ P,ATOM
JUMPE A,SUBS2
CRETJ:
SPROG3: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
SUBS3: POP P,B
JRST XCONS
;DELQ DELETE DLT3 DLT2 DLT1 .DELQ .DELETE MEMQ MEMQ1
DELQ: SKIPA D,[SMEMQ] ;USES A,B,C,T,TT. MUST SAVE AR2A - SSMACRO
DELETE: MOVEI D,SMEMBER ;USES A,B,C,AR1,AR2A,T,TT
MOVEI TT,-1 ;MUST SAVE R, SEE GCP6H1
CAMN T,XC-2
JRST DLT3
CAME T,XC-3
JRST DLTER
POP P,A
JSP T,FLTSKP
JRST .+2
JSP T,IFIX
DLT3: MOVEM TT,DLTC
MOVEI TT,(P)
SKIPA B,(P)
DLT2: HRRM B,(TT)
MOVEM TT,TABLU1
MOVE A,-1(P)
SOSGE DLTC
JRST DLT1
PUSHJ P,(D) ;MEMBER OR MEMQ
JUMPE A,DLT1
HRRZ B,(A)
SKIPN TT,MEMV
MOVE TT,TABLU1
JRST DLT2
DLT1: POP P,A
JRST POP1J
.DELQ: SKIPA D,[SMEMQ]
.DELETE:
MOVEI D,MEMBER
PUSH P,A
PUSH P,B
MOVEI TT,-1
JRST DLT3
MEMQ: SKIPE V.RSET
JRST SMEMQ
MEMQ1: JUMPE B,FALSE .SEE THRCAB ;REQUIRES MEMQ1 PRESERVES TT
HLRZ T,(B)
CAIN T,(A)
JRST BRETJ
HRRZ B,(B)
JRST MEMQ1
;NUMP TYPEP TYPNIL %SYMBOLP
SUBTTL FLOATP, FIXP, NUMBERP, TYPEP, AND PDLNMK ROUTINE
IRP NUMP,,[FIXP,FLOATP,NUMBERP]BITS,,[FX+BN,FL,FX+FL+BN]
NUMP: SKOTT A,BITS
JRST FALSE ;RETURN NIL IF NOT OF DESIRED TYPE
MOVE TT,(A) ;RETURN T IF WHAT WE WANT. ALSO, TT GETS THE NUMBER.
JRST TRUE ;IF NUMBERP GETS A BIGNUM, TT GETS THE CORRECT SIGN, ANYWAY
TERMIN
TYPEP: JUMPE A,TYPNIL ;SUBR 1 - USES ONLY A
ROT A,-SEGLOG
HRRZ A,ST(A)
POPJ P,
TYPNIL: MOVEI A,QSYMBOL
POPJ P,
%SYMBOLP: ;SUBR 1
JSP T,SPATOM
JRST FALSE
JRST TRUE
;NMCK0 NUMCHK PDLNKJ PDLNMK PDLNM0 NMK1 PNMK2 CPDLNKJ
NMCK0: POP P,A
NUMCHK: ;CHECK TO SEE THAT WE HAVE A NUMBER, THEN EXIT
IFE NARITH,[
BG% JSP T,FLTSKP
BG$ JSP T,NVSKIP
BG$ POPJ P,
JFCL ;FALLS INTO PDLNKJ
] ;END OF IFE NARITH
IFN NARITH, WARN [NUMCHK? PDLNMK?]
PDLNKJ: MOVEI T,CPOPJ ;PDLNKJ = PDLNMK, THEN POPJ P,
PDLNMK: CAML A,NPDLL ;FIRST A QUICK AND DIRTY CHECK
CAMLE A,NPDLH
JRST (T)
PDLNM0: ROT A,-SEGLOG ;NOW TO CHECK THE ST ENTRY
SPECPRO INTROT
HLL T,ST(A)
ROT A,SEGLOG
NOPRO
TLNN T,$PDLNM ;SKIP IFF PDL NUMBER
JRST (T)
PUSH P,T
NMK1: MOVEM TT,PNMK1 ;EXPECTS TYPE BITS IN T
MOVE TT,(A)
HRRI T,PNMK2 ;MUST SAVE TT
TLNN T,FL ;FIGURE OUT WHICH KIND OF CONS TO DO
JRST FXCONS ; - FIXNUM
JRST FLCONS ; - FLONUM
PNMK2: MOVE TT,PNMK1 ;RESTORE TT FOR PDLNMK
CPDLNKJ: POPJ P,PDLNKJ
;GCPRO %GCPRO GCPR1 GCPR2 .GCPRO .GCPR5 GCPR3 GCPR4
SUBTTL GCPRO AND SXHASH
GCPRO: JUMPE B,GCREL
CAIN B,QM ;SECOND ARG = ? MEANS ONLY GCLOOK
JRST GCLOOK
%GCPRO: MOVEI AR1,1 ;MUST SAVE R,F - FOR FASLOAD
GCPR1: CAIL A,IN0-XLONUM
CAILE A,IN0+XHINUM-1
SKIPA
POPJ P,
SKOTT A,SY
JRST GCPR2
JUMPLE AR1,CPOPJ
HLRZ T,(A)
MOVSI TT,SY.CCN\SY.OTC ;COMPILED CODE NEEDS ME BIT
MOVSI D,SY.PUR ;PURE SYMBOL BLOCK BIT
TDNN D,(T)
IORM TT,(T)
POPJ P,
GCPR2: MOVE AR2A,A ;SAVE ARG
PUSHJ P,SXHSH0 ;LEAVES HASHKEY IN D
MOVE A,AR2A
MOVE T,AR1 ;T=0 => RELEASE, ELSE PROTECT
.GCPRO: JUMPE A,CPOPJ
LOCKI
PUSH P,A ;PLACES ORIG ARG ON PDL
PUSHJ P,SAVX5 ;SAVES NUM ACS
SKIPE B,GCPSAR
JRST .GCPR5
MOVEI A,NIL
MOVE TT,LOSEF
ADDI TT,1
LSH TT,-1
PUSHJ P,MKLSAR
MOVE D,-2(FXP) ;RESTORE HASHKEY IN D
MOVEM B,GCPSAR
.GCPR5: MOVE T,D ;ARG ON P, AND SAVES NUM ACS ON FXP
LSH T,-1
IDIV T,LOSEF
PUSH FXP,TT
MOVEI A,(FXP)
PUSHJ P,@ASAR(B)
SUB FXP,R70+1
MOVEM R,-3(FXP)
MOVE B,A
MOVE A,(P) ;ORIG ARG ON P
PUSH P,B ;SAVE PROLIST BUCKET
SKIPN -4(FXP)
JRST GCRL1 ;GO RELEASE IF FLAG SO SET.
PUSHJ P,MEMBER
JUMPN A,GCPR3 ;ITEM ALREADY IN PROTECTIVE BUCKET
SKIPG -4(FXP)
JRST GCPR4
MOVE A,-1(P) ;ORIGINAL ARG
MOVE B,(P) ;CONSED ONTO PROLIST BUKET
PUSHJ P,CONS
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
GCPR3: HLRZ A,(A)
GCPR4: PUSHJ P,RSTX5
SUB P,R70+2
UNLKPOPJ
;GCRL1 GCREL GCLOOK
GCRL1: CALLF 2,QDELETE ;GCRELEASE
MOVE R,-3(FXP)
HRRZ D,GCPSAR
JSP T,.STOR0
JRST GCPR4
GCREL: TDZA AR1,AR1
GCLOOK: MOVNI AR1,1
SKIPN GCPSAR
JRST FALSE
JRST GCPR1
;SXHASH ATMHSH BNHSH AHSH1 AHSH2 NILHSH SXHSH0
SXHASH: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE
PUSHJ P,SXHSH0 ;SAVE F - SEE DEFUN
MOVE TT,D
POPJ P,
ATMHSH: ;HASH A PRINT NAME
BNHSH: SETZ T, ;HASH A BIGNUM (SAME ALGORITHM)
SKIPA B,A
AHSH1: HRRZ B,(B)
JUMPE B,AHSH2
HLRZ C,(B)
XOR T,(C)
JRST AHSH1
AHSH2: LSH T,-1 ;FOR ATOMS, THIS INSURES THAT THE HASHKEY IS POSITIVE
JRST (TT)
NILHSH: MOVE D,[<ASCII \NIL\>←-1] ;HASH NIL FASTLY
POPJ P,
SXHSH0: JUMPE A,NILHSH ;RETURNS S-EXPR'S HASHKEY IN D
SKOTT A,LS
2DIF JRST @(TT),SXHSH9-1,QLIST .SEE STDISP
HRRZ B,(A)
PUSH P,B
HLRZ A,(A)
PUSHJ P,SXHSH0
ROT D,-1
PUSH FXP,D
POP P,A
PUSHJ P,SXHSH0
POP FXP,T
ADD D,T
POPJ P,
;SXHSH8 SXHSH7 SXHSH4 SYMHSH SXHSH5 SXHSH6 SXHSH9 SXHSD1 SXHSD2 SXHSC1 SXHSZ1 SXHS1A SXHS1B SXHS1F
SXHSH8: MOVM D,(A) ;FLONUM
POPJ P,
SXHSH7: MOVE D,(A) ;FIXNUM
POPJ P,
IFN BIGNUM,[
SXHSH4: HRRZ A,(A) ;BIGNUM
JSP TT,BNHSH
MOVE D,T
POPJ P,
] ;END OF IFN BIGNUM
SYMHSH:
SXHSH5: HLRZ T,(A) ;SYMBOL
HRRZ A,1(T)
JSP TT,ATMHSH
SKIPA D,T
SXHSH6: MOVEI D,(A)
POPJ P, ;RANDOM, ARRAY
SXHSH9: SXHSH7 ;FIXNUM
SXHSH8 ;FLONUM
DB$ SXHSD1 ;DOUBLE
CX$ SXHSC1 ;COMPLEX
DX$ SXHSZ1 ;DUPLEX
BG$ SXHSH4 ;BIGNUM
SXHSH5 ;SYMBOL
HN$ REPEAT HNKLOG+1, SXHS1A ;HUNKS
SXHSH6 ;RANDOM
SXHSH6 ;ARRAY
IFN .-SXHSH9-NTYPES+1, WARN [WRONG LENGTH TABLE]
IFN DBFLAG,[
SXHSD1: MOVE D,1(A)
KA ASH D,10
] ;END OF IFN DBFLAG
IFN DBFLAG+CXFLAG,[
SXHSD2: ADD D,(A)
POPJ P,
] ;END OF IFN DBFLAG+CXFLAG
IFN CXFLAG,[
SXHSC1: MOVS D,1(A)
JRST SXHSD2
] ;END OF IFN CXFLAG
IFN DXFLAG,[
SXHSZ1: MOVE D,3(A)
KA ASH D,10
SUB D,2(A)
KA MOVE T,1(A)
KA ASH T,10
KA XOR D,T
KIKL XOR D,1(A)
JRST SXHSD2
] ;END OF IFN DXFLAG
IFN HNKLOG,[
SXHS1A: MOVSI T,-1
2DIF [LSH T,(TT)]0,QHUNK0
PUSH P,A
HRRI T,(A)
PUSH P,T
PUSH FXP,R70
SXHS1B: HLRZ A,(T)
PUSHJ P,SXHSH0
ROT D,1
ADDM D,(FXP)
MOVE T,(P)
HRRZ A,(T)
PUSHJ P,SXHSH0
ADD D,(FXP)
ROT D,2
MOVEM D,(FXP)
MOVE T,(P)
AOBJP T,SXHS1F
MOVEM T,(P)
JRST SXHS1B
SXHS1F: SUB P,R70+2
JRST POPXDJ
] ;END OF IFN HNKLOG
;MAPATOMS MAPAT1 MAPAT2 MAPAT9
SUBTTL MAPPING FUNCTIONS
;;; MAPATOMS FUNCTION
;;; (MAPATOMS FN) CALLS FN REPEATEDLY, FEEDING IT SUCCESSIVE
;;; ATOMS FROM THE CURRENT OBARRAY. OPTIONAL SECOND ARG
;;; SPECIFIES OBARRAY (MUST BE A SAR!). RETURNS NIL.
MAPATOMS:
MOVEI D,QMAPATOMS
AOJG T,S1WNALOSE
AOJL T,S2WNALOSE
SKIPE T ;SECOND ARG DEFAULTS TO
PUSH P,VOBARRAY ; CURRENT OBARRAY
MOVEI TT,(CALL 1,)
HRLM TT,-1(P)
PUSH P,R70
PUSH FXP,[OBTSIZ] ;NUMBER OF BUCKETS
MAPAT1: SOSGE TT,(FXP) ;TT GETS BUCKET NUMBER
JRST MAPAT9
HRRZ AR1,-1(P)
ROT TT,-1
HLRZ A,@TTSAR(AR1) ;FETCH BUCKET
SKIPGE TT
HRRZ A,@TTSAR(AR1)
MOVEM A,(P) ;SAVE BUCKET
MAPAT2: SKIPN B,(P) ;MAPCAR DOWN BUCKET
JRST MAPAT1
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,(P)
XCT -2(P) ;CALL SUPPLIED FUNCTION
JRST MAPAT2
MAPAT9: SUB FXP,R70+1 ;EXIT, RETURNING NIL
SUB P,R70+3
JRST FALSE
;MAPLIST MAPCAR $MAP MAPC MAPCON $MAPCAN MAPL0 MAPL1 MAPL1B
;;; PDL STRUCTURE FOR MAP SERIES
;;; ,,RETURN ;LEFT HALF MAY HAVE BAKTRACE INFO
;;; ,,EVENTUAL VALUE ;LEFT HALF HAS LAST OF VALUE LIST
;;; LIST1 ;SECOND ARG
;;; LIST2 ;THIRD ARG
;;; LIST3 ;FOURTH ARG
;;; ...
;;; LISTN ;LAST ARG
;;; -N,,<ADDRESS OF LIST1 ON STACK>
;;; CODE,,MODE ;CODE TELLS WHAT KIND OF MAP, MODE TELLS HOW TO CALL FN
;;; ; (MODE IS ADDRESS OF PLACE WHICH SETS UP ARGS FOR FN)
;;; MAPL6 ;OR MAYBE MAPL3 - THIS IS WHERE FN CALL RETURNS TO
;;; JCALL K,FN ;FN=FIRST ARG - K=1,2,3,4,5, OR 16
;;; ;UUO HANDLER MAY CLOBBER THIS WITH A JRST
;;; ;IF NEVER GOING TO BE XCT'ED, JCALL NEED NOT BE THERE
MAPLIST: JSP TT,MAPL0 ;CODE 0
MAPCAR: JSP TT,MAPL0 ;CODE 1
$MAP: JSP TT,MAPL0 ;CODE 2
MAPC: JSP TT,MAPL0 ;CODE 3
MAPCON: JSP TT,MAPL0 ;CODE 4
$MAPCAN: JSP TT,MAPL0 ;CODE 5
MAPL0: AOJGE T,MAPWNA ;LOSE IF ONLY ONE ARG
MOVE D,T
ADDI D,1(P) ;D HAS ADDRESS OF LIST1 ON STACK
HRLI D,(T)
PUSH P,D
2DIF [MOVSI TT,(TT)]-1,MAPLIST
PUSH P,TT ;SAVE CODE - FIGURE OUT MODE LATER
TLNE TT,2 ;SKIP IF WE'LL BE SAVING UP RESULTS
SKIPA A,(D) ;ELSE WE'LL JUST RETURN FIRST LIST AS VALUE
MOVSI A,-1(D)
EXCH A,-1(D) ;INIT EVENTUAL VALUE SLOT - A NOW HAS FIRST ARG (FN)
JSP T,SPATOM
JRST MAPL5 ;FOOEY, IT'S NOT A SYMBOL
HRRZ C,(A)
MAPL1: JUMPE C,MAPL5 ;FOOEY, IT'S A SYMBOL WITH NO FUNCTION PROPERTY
HLRZ B,(C)
HRRZ C,(C)
HRRZ C,(C)
CAIL B,QARRAY ;REMEMBER, SYMBOLS DENOTING FUNCTION PROPS
CAILE B,QFEXPR ; ARE CONSECUTIVE IN SYMBOL SPACE
JRST MAPL1
CAIE B,QARRAY
CAIN B,QSUBR
JRST MAPL5A ;GO FIGURE OUT JCALL FOR A SUBR OR ARRAY
CAIE B,QLSUBR
JRST MAPL5 ;FOOEY, IT'S SOMETHING WE CAN'T LINK TO WELL
PUSH P,CMAPL3
HRLI A,(JCALL 16,)
MOVEI B,MAPL23
MAPL1B: HRRM B,-1(P) ;B HAS MODE - SAVE IT
PUSH P,A ;SAVE FN (MAYBE WITH JCALL K, IN LEFT HALF)
JRST MAPL2
;MAPL3 CMAPL6 MAPL3A MAPL6 MAPL6A MAPL7 MAPL7A MAPL2 MAPL21 MAPL40 MAPL4 CMAPL3 MAPL22 MAPL23 MAPL24
MAPL3: MOVE D,(P) ;GET FUNCTION CALL FROM STACK
TLNE D,700000 ;SKIP IF IT DIDN'T GET CLOBBERED
JRST MAPL3A
MOVEI D,MAPL24 ;OH, WELL! MIGHT AS WELL USE MODE
HRRM D,-2(P) ; FOR UNCLOBBERABLE FNS
CMAPL6:
MAPL3A: MOVEI D,MAPL6
MOVEM D,-1(P) ;WE ONLY NEED TO DO A MAPL3 CHECK ONCE
MAPL6: MOVE D,-3(P) ;D POINTS TO LIST1 ON STACK
HLRZ C,-1(D) ;C GETS POINTER TO LAST OF VALUE
JUMPE C,MAPL7 ;THIS IS REALLY A MAP OR MAPC
HLLZ B,-2(P) ;GET CODE IN LEFT HALF OF B
TLNE B,4
JRST MAPL8 ;MAPCAN OR MAPCON
PUSHJ P,CONS ;MAPCAR OR MAPLIST - NOTE THAT B IS NIL
HRRM A,(C) ;CLOBBER INTO END OF LIST
MAPL6A: HRLM A,-1(D) ;SAVE NEW LAST POINTER
MAPL7: MOVE TT,(D)
MAPL7A: HRRZ A,(TT) ;TAKE CDR OF ALL LISTS
MOVEM A,(D)
SKIPL TT,1(D)
AOJA D,MAPL7A
MOVE D,TT ;NOW D POINTS TO LIST1 ON STACK AGAIN
MAPL2: MOVE B,-2(P)
MOVE C,P ;SAVE C FOR A QUICK GETAWAY
PUSH P,-1(P) ;WHERE CALL TO FN SHOULD RETURN
MAPL21: SKIPG A,(D) ;D POINTS TO VECTOR OF LISTS
JRST MAPL22 ;REMEMBER, <-N,,XXX> IS JUST AFTER <LISTN>
MOVEI TT,(A)
LSH TT,-SEGLOG
SKIPL ST(TT) ;END-OF-LIST TEST
JRST MAPL40
TLNE B,1 ;SKIP UNLESS THIS IS A "CAR" KIND OF MAP
HLRZ A,(A)
PUSH P,A ;PUSH ARG
AOJA D,MAPL21 ;IF NOT END, GO CHECK OUT NEXT LIST
MAPL40: JUMPE A,MAPL4
LER3 [SIXBIT \NON-NULL TERMINATION OF LIST - MAP!\]
MAPL4: MOVE P,C ;THIS POPS OFF FASTLY ANY UNNEEDED STUFF
HLRZ T,-3(P) ;GET -N IN T
SUBI T,4
HRLI T,-1(T)
ADD P,T ;FASTLY POP OFF FN, MODE, ALL LISTS, ETC.
POP P,A ;FINAL VALUE GOES IN A
TLZ A,-1 ;ZERO ANY LEFT HALF GARBAGE
CMAPL3: POPJ P,MAPL3 ;HOORAY!
MAPL22: JUMPE A,MAPL4 ;NIL IS NORMAL END-OF-LIST
SETZB A,B ;MAY HAVE GARBAGE IN LEFT HALVES
HLRE T,(D) ;T GETS -N IN CASE OF LSUBR CALL
MOVE TT,1(D) ;GET MODE (D POINTS TO <-N,,XXX> ON STACK)
JSP R,(TT) ;FOR SUBRS, GOES TO PDLA2-N
MAPL23: XCT 3(D) ;GO HERE FOR LSUBRS
MAPL24: MOVEM T,UUTSV ;GO HERE FOR UNCLOBBERABLE CALL
MOVE T,3(D) ;SAVE SOME OF THE UUOH TROUBLE BY
HRLI T,(JCALLF 16,) ; ENTERING THE UUO MESS MORE DIRECTLY
MOVEM T,40
TLZ T,-1
MOVEI R,1 ;R=1 MEANS LSUBR CALL
SETZM UUOH
JRST UUOH0A
;MAPL5 MAPL5A MAPL8 MAPL8B MAPL8C MAPL8A .MAP .MAP1 SET SETCK
MAPL5: PUSH P,CMAPL6 ;SET UP FOR UNCLOBBERABLE FN CALL
MOVEI B,MAPL24
JRST MAPL1B
MAPL5A: HLRE T,-1(P)
CAMGE T,XC-5 ;CHECK NUMBER OF ARGS FOR FN
JRST MAPL5 ;FOOEY, TOO MANY ARGS FOR SUBR CALL
PUSH P,CMAPL3
MOVM TT,T
LSH TT,5
TLO A,(JCALL)(TT) ;MAKE UP JCALL OF RIGHT # OF ARGS
MOVEI B,PDLA2(T) ;MODE = PDLA2-<# OF ARGS>
JRST MAPL1B
MAPL8: JUMPE A,MAPL7 ;NCONC'ING NIL DOES VERY LITTLE
HRRM A,(C) ;CLOBBER INTO LAST OF PREVIOUS THING
SKIPE V.RSET
JRST MAPL8A
MOVE T,A
MAPL8B: HRRZ TT,(T) ;AN OPEN-CODING OF THE SUPER-FAST "LAST"
JUMPE TT,MAPL8C
HRRZ T,(TT)
JUMPN T,MAPL8B
SKIPA A,TT
MAPL8C: MOVEI A,(T)
JRST MAPL6A
MAPL8A: MOVE T,D
PUSHJ P,LAST ;FIND LAST OF THIS NEW FROB
MOVE D,T
JRST MAPL6A
.MAP: JSP TT,.MAP1 ;MAPCAN
JSP TT,.MAP1 ;MAPCON
JSP TT,.MAP1 ;MAPC
JSP TT,.MAP1 ;MAP
JSP TT,.MAP1 ;MAPCAR
JSP TT,.MAP1 ;MAPLIST
.MAP1: JUMPE A,CPOPJ
TLNE A,-1 ;RIDICULOUS CHECK FOR HORRIBLE
.VALUE ; COMPILER LOSSES
PUSH P,B ;LIST IN A, FUNCTION IN B,
PUSH P,A ;NUMBER IN TT IS INDEX
MOVNI T,2
10$ SUBI TT,.MAP+A ;LOSING D10!!!
10$ MOVNS TT ;NO NEGATIVE RELOC ALLOWED!
.ELSE MOVNI TT,-.MAP-A(TT)
JRST $MAPCAN(TT)
SET: JSP D,SETCK ;SUBR 2
EXCH B,A ;FORTUNATELY, NOT USED BY COMPILED CODE
JSP T,PDLNMK
EXCH B,A
EXCH B,AR1
JSP T,.SET1
EXCH B,AR1
POPJ P,
SETCK: JSP T,SPATOM
JSP T,PNGE1
JRST (D)
;$BREAK $BRK0 CB CN.BB UDFB UBVB WTAB UGTB WNAB GCLB PDLB GCOB IOLB FACB BKCOM BKCOM0 BKCOM2 CBKCM0 BKCOM1
SUBTTL VARIOUS BREAK ROUTINES
$BREAK: JUMPE A,CPOPJ ;*BREAK - SUBR 2
$BRK0: MOVEI A,(B) ;A = BREAKP, B = BREAKID
HRRZ B,V.
HRRZ AR1,VIPLUS
HRRZ AR2A,VIDIFF
JSP T,SPECBIND ;DO *NOT* BIND ↑R
TAPRED ;↑Q
TTYOFF ;↑W
VEVALHOOK ;EVALHOOK
V%TERPRI ;TERPRI
0 B,V. ;*
0 AR1,VIPLUS ;+
0 AR2A,VIDIFF ;-
MOVEI B,$DEVICE
MOVEI C,UNTYI
JSP T,SPECBIND
0 B,TYIMAN
0 C,UNTYIMAN
MOVEI AR2A,TRUTH
JSP T,SPECBIND
0 AR2A,V%TERPRI
STRT 17,[SIXBIT \↑M;BKPT !\]
HRRZ AR1,VMSGFILES
TLO AR1,200000
PUSHJ P,$PRINC
STRT 17,STRTCR
PUSHJ P,UNBIND ;UNBIND V%TERPR
MOVE A,VIDIFFERENCE
MOVEM A,VIPLUS
MOVEI D,BRLP ;FUNCTION TO EXECUTE
PUSHJ P,BRGEN ;CATCH AND ERRSET AROUND A READ-EVAL-PRINT LOOP
JSP F,LINMDP
PUSHJ P,ITERPRI
PUSHJ P,UNBIND
JRST UNBIND
CB: SKIPN V.RSET ;CALL BREAK - *RSET ERROR
POPJ P,
SKIPA B,[Q.R.TP]
CN.BB: MOVEI B,QCN.B ;CONTROL-B BREAK
PUSHJ P,IOGBND
JRST BKCOM2
UDFB: MOVEI B,QUDF ;UNDEFINED FUNCTION BREAK
JRST BKCOM
UBVB: MOVEI B,QUBV ;UNBOUND VARIABLE BREAK
JRST BKCOM
WTAB: MOVEI B,QWTA ;WRONG TYPE OF ARGUMENT BREAK
JRST BKCOM
UGTB: MOVEI B,QUGT ;UNSEEN GO TAG BREAK
JRST BKCOM
WNAB: MOVEI B,QWNA ;WRONG # ARGS BREAK
JRST BKCOM
GCLB: MOVEI B,QGCL ;FAILED TO GARBAGE-COLLECT ENOUGH SPACE BREAK
JRST BKCOM
PDLB: MOVEI B,QPDL ;PDL OVERFLOW BREAK
JRST BKCOM
GCOB: MOVEI B,QGCO ;GC OVERFLOW BREAK
JRST BKCOM
IOLB: MOVEI B,QIOL ;I/O LOSSAGE BREAK
JRST BKCOM
FACB: MOVEI B,QFAC ;FAILED ACTION REQUEST BREAK
BKCOM:
PUSHJ P,IOGBND
SAVE A B
PUSH P,CBKCM0
PUSH P,R70
PUSH P,VMSGFILES
MOVNI T,2
JRST ERRPRINT
BKCOM0:
JSP R,RSTR2
BKCOM2: MOVEI AR1,READTABLE
MOVEI AR2A,OBARRAY
JSP T,SPECBIND
0 A,VARGS ;SPECIAL VALUE CELL OF ARGS
0 AR1,VREADTABLE ;RESET READTABLE AND OBARRAY
0 AR2A,VOBARRAY ; TO STANDARD (INITIAL) ONES
CBKCM0: SETZ A,BKCOM0
PUSHJ P,NOINTERRUPT
MOVEI A,TRUTH
PUSHJ P,$BREAK
BKCOM1: PUSHJ P,UNBIND
JRST UNBIND
;INTERN INTRN3 INTRN1 INTRN INTRN4 MAKF MAKF1 MAK2 MAK4 MAK3
SUBTTL INTERN FUNCTION AND RELATED ROUTINES
INTERN: PUSH P,A ;ONLY INIT ENTERS INTERN AT INTRN0
INTRN3: PUSHJ P,PNGET ;MUST SAVE F - SEE FASLOAD
SETOM LPNF
INTRN1: SETZM RINF
JSP TT,ATMHSH ;LEAVES ATOM'S HASHKEY IN T
MOVEI AR2A,(A)
HLRZ C,(A)
INTRN: TLZ T,400000
IDIVI T,OBTSIZ
HRLM TT,(P)
INTRN4: LOCKI ;SO THAT NO INTERRUPT SNEAKS SOMETHING ON THE
SKIPN D,VOBARRAY ; OBLIST JUST AFTER WE DECIDE IT ISNT THERE
JRST INTNCO
MOVEI C,(D)
LSH C,-SEGLOG
MOVE C,ST(C)
TLNN C,SA
JRST INTNCO
MOVE T,ASAR(D)
TLNN T,AS<OBA>
JRST INTNCO
ROT TT,-1 ;GET BUCKET
JUMPL TT,.+3
HLRZ A,@TTSAR(D)
SKIPA
HRRZ A,@TTSAR(D)
PUSH FXP,TT
JUMPE A,MAKA0
MOVEI C,A
MAKF: MOVE AR1,C
HRRZ C,(C)
JUMPE C,MAKA
HLRZ AR1,(C)
SKIPN AR1
TROA AR1,$$$NIL ;BEWARE THE SKIP!
MAKF1: HLRZ AR1,(AR1)
HRRZ AR1,1(AR1)
SKIPN T,RINF ;RINF HAS ZERO WHEN IN REGULAR INTERN
MOVEI T,(AR2A)
MAK2: JUMPE AR1,MAK1
JUMPE T,MAKF
HLRZ B,(AR1)
MOVE B,(B)
SKIPN RINF
JRST MAK4
CAME B,@RNTN2 ;<END OF PNAME>(T)
JRST MAKF ;COMPARE FOR RINTERN
AOJA T,MAK3
MAK4: HLRZ D,(T) ;COMPARE FOR REGULAR INTERN
CAME B,(D)
JRST MAKF
HRRZ T,(T)
MAK3: HRRZ AR1,(AR1)
JRST MAK2
;MAKA3 MAKA3A MAKA0 MAKA MAKA2 MAKA5 MAKA4 MAK1
MAKA3: HRRZ A,(P)
SKIPGE LPNF
JRST MAKA2
SKIPE B,V.PURE ;INTERN MAKES PURE SY2 IF *PURE=T ANDNOT SYMBOL
CAIN B,QSYMBOL
JRST MAKA3A
PUSHJ P,PSYCONS
JRST MAKA2
MAKA3A: PUSHJ P,SYCONS
JRST MAKA2
MAKA0: TDZA D,D ;D=0 => BUCKET WAS EMPTY BEFORE THIS CALL
MAKA: MOVEI D,1
MOVN C,RINF ;MAKE-UP NEW ATOM
JUMPE C,MAKA3
PUSHJ P,PNGNK
MAKA2: PUSHJ P,NCONS
MOVE TT,(FXP)
JUMPE D,MAKA5
HRRM A,(AR1) ;NCONC ONTO END OF BUCKET
JRST MAKA4
MAKA5: HRRZ D,VOBARRAY
JUMPL TT,.+3
HRLM A,@TTSAR(D)
SKIPA
HRRM A,@TTSAR(D)
MAKA4: SKIPA C,A
MAK1: JUMPN T,MAKF ;ATOM FOUND ON OBLIST
HLRZ A,(C)
POP FXP,TT ;SHOULD EXIT WITH OBTBL BUCKET # IN TT
SUB P,R70+1
UNLKPOPJ
;RINTERN RINTN0 INTRN2 RINTN1
;;; COME HERE TO INTERN AN ATOM WHOSE PRINT NAME IS IN PNBUF.
RINTERN:
CAMN C,[350700,,PNBUF] ;SAVES F
JRST RINTN1
RINTN0: PUSH FXP,T
PUSH P,CPXTJ
PUSH P,A ;ENTERING INTERN AFTER THE "PUSH P A", SO MUST DO HERE
SKIPL LPNF
JRST INTRN1
ADDI C,1
HRRM C,RNTN2
2DIF [MOVEI C,(C)]0,PNBUF
MOVNM C,RINF
INTRN2: MOVEI C,PNBUF ;DUPLICATE PNAME HASHING ALGORITHM
MOVE T,PNBUF ; AS USED IN SXHASH
MOVN D,RINF
SOJLE D,.+3
XOR T,PNBUF(D)
JRST .-2
LSH T,-1
JRST INTRN
RINTN1: SKIPL LPNF
JRST RINTN0
MOVE TT,PNBUF
ROT TT,6
ADDI TT,<OBTSIZ+1>/2 ;### OBTSIZ MUST BE ODD
MOVE D,VOBARRAY
JUMPL TT,.+3
HLRZ A,@1(D)
SKIPA
HRRZ A,@1(D)
JUMPN A,CPOPJ
PUSH FXP,TT
PUSHJ P,RINTN0
POP FXP,TT
MOVE D,VOBARRAY
JUMPL TT,.+3
HRLM A,@1(D)
POPJ P,
HRRM A,@1(D)
POPJ P,
;IMPLODE MAKNAM CRINTERN MKNM1 MKNM2 RDL12 MKNM4 CHNV1X CHNV1 CHNV1D CHNV1A CHNV1B CHNV1C
IMPLODE:
SKIPA T,CRINTERN ;SUBR 1
MAKNAM: MOVEI T,PNGNK1 ;SUBR 1
JUMPE A,MKNM4
PUSH P,T
PUSH P,RDLARG
HRRZM A,RDLARG
MOVEI T,MKNM1
PUSHJ FXP,MKNR6C
POP P,RDLARG
CRINTERN:
POPJ P,RINTERN
MKNM1: SKIPN A,RDLARG
POPJ P,
HRRZ B,(A)
MOVEM B,RDLARG
HLRZ A,(A)
MKNM2: JSP T,CHNV1
JRST POPJ1
RDL12: MOVEI T,RINTERN
MKNM4: SETZM PNBUF
JSP TT,IRDA
JRST (T) ;PNGNK1 OR RINTERN, THEN POPJ P,
;;; GET CHARACTER NUMERIC VALUE
CHNV1X: TLO T,1
CHNV1: SKOTT A,SY+FX
JRST CHNV1C
TLNN TT,SY
JRST CHNV1A
CHNV1D: HLRZ TT,(A)
HRRZ TT,1(TT)
HLRZ TT,(TT)
LDB TT,[350700,,(TT)]
JRST CHNV1B
CHNV1A: MOVE TT,(A)
TLNN T,1
CHNV1B:
SA% TDNN TT,[-200]
SA$ TDNN TT,[-1000]
JRST (T)
CHNV1C: WTA [NOT ASCII CHARACTER!]
JRST CHNV1
;DEFPROP DEF1 DEF1B DEF9 DFPR2 DFPR1
SUBTTL DEFPROP AND DEFUN
;;; THE BASIC IDEA OF DEFPROP IS:
;;; (DEFUN DEFPROP FEXPR (X)
;;; (DO () ((NULL (REMPROP (CAR X) (CADDR X)))))
;;; (PUTPROP (CAR X) (CADR X) (CADDR X)))
;;; THAT IS, REMOVE *ALL* OCCURRENCES OF THE PROPERTY BEFORE
;;; PUTTING ON THE NEW VALUE.
DEFPROP: ;FEXPR
REPEAT 2, PUSH P,A
JSP T,DFPR2
JSP T,DFPR1
JRST DFPER
HRRZ TT,(C)
JUMPN TT,DFPER
HLRZ A,(A)
HLRZ AR1,(B)
HLRZ B,(C)
MOVEI C,(B)
;SYMBOL IN A; PROPERTY NAME IN B *AND* C; PROPERTY VALUE IN AR1.
DEF1: MOVEI AR2A,(A) ;DEFUN COMES IN HERE
DEF1B: PUSHJ P,REMPROP ;REMPROP SAVES C, AR1, AR2A
MOVEI B,(AR1)
JUMPN A,DEF1B ;REMOVE ALL OCCURRENCES OF THE PROPERTY
MOVEI A,(AR2A)
PUSHJ P,PUTPROP
DEF9: POP P,A ;PUT NEW VALUE FOR PROPERTY
POPI P,1
JRST $CAR
DFPR2: HLRZ B,(A) ;SOME HAIRY CHECKS FOR DEFPROP AND DEFUN
SKOTT B,SY ;SKIPS ON *FAILURE* TO GET A VALID SYMBOL
JUMPN B,1(T)
JRST (T)
DFPR1: JUMPE A,(T) ;MORE HAIRY CHECKS FOR DEFPROP AND DEFUN
HRRZ B,(A) ;SKIPS ON *SUCCESS*
JUMPE B,(T) ;LEAVES STUFF SPREAD OUT IN A, B, C
HRRZ C,(B)
JUMPE C,(T)
JRST 1(T)
;DEFUN DEF7 DEF3 DEF3B DEF3X DEF3L DEF3A DEF6 DEF5 DEF4
;;; (DEFUN <SPEC> <FLAG> <ARGS> . <BODY>) DEFINES A FUNCTION.
;;; <FLAG> MAY BE OMITTED, OR MAY BE "EXPR", "FEXPR", OR "MACRO".
;;; <SPEC> MAY BE A SYMBOL (THE NAME OF THE FUNCTION), OR A LIST OF
;;; TWO TO FOUR SYMBOLS (IN WHICH CASE THE FLAG "MACRO" IS ILLEGAL).
;;; <ARGS> IS A NON-NIL SYMBOL OR A LIST OF SYMBOLS; THE FORMER INDICATES
;;; AN LEXPR (INCOMPATIBLE WITH THE "MACRO" AND "FEXPR" FLAGS).
;;; OTHER FORMATS FOR <ARGS>, INCLUDING APPEARANCE OF & KEYWORDS,
;;; CAUSES THE MACRO "DEFUN&" TO BE RUN INSTEAD.
;;;
;;; IF THE VALUE OF THE SWITCH DEFUN IS T, THEN THE EXPR-HASH HACK
;;; IS ENABLED. IN THIS CASE, DEFUN AVOIDS MAKING THE INTERPRETIVE
;;; DEFINITION IF HASHING THE DEFINITION INDICATES THAT IT IS
;;; THE SAME AS THE CURRENT, PRESUMABLY COMPILED, DEFINITION.
;;; THE VARIOUS CASES ARE:
;;; FORM OF <SPEC>:
;;; FOO (FOO BAR) (FOO BAR BAZ) (FOO BAR BAZ QUUX)
;;; EXPR-HASH PROPERTY IS ON THE ATOM:
;;; FOO (GET 'FOO 'BAR) - NONE - FOO
;;; [IF THIS IS A SYMBOL]
;;; EXPR-HASH PROPERTY INDICATOR IS:
;;; EXPR-HASH EXPR-HASH - NONE - QUUX
;;; DEFUN PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY:
;;; EXPR/FEXPR/MACRO BAR BAR BAR
;;; COMPILER PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY:
;;; SUBR/FSUBR/LSUBR BAR * BAZ BAZ
;;; * THE PROPERTY WILL BE A SYMBOL |FOO BAR| WHICH IN TURN
;;; WILL HAVE THE APPROPRIATE SUBR/FSUBR/LSUBR PROPERTY.
DEFUN:
REPEAT 2, PUSH P,A
DEF7: HRRZ A,(A)
HLRZ AR1,(A)
CAIN AR1,QEXPR
JRST DEF3
CAIE AR1,QFEXPR
CAIN AR1,QMACRO
JRST DEF3 ;(DEFUN <SPEC> <FLAG> ...)
MOVEI AR1,QEXPR ;(DEFUN <SPEC> ...); <FLAG> DEFAULTS TO EXPR
MOVE A,(P)
;<FLAG> IS IN AR1; THE CDR OF A IS (<ARGS> ...); THE CAR OF (P) IS <SPEC>.
DEF3: JSP T,DFPR1 ;MAKE SURE WE HAVE AT LEAST TWO THINGS
JRST DEFNER
HLRZ TT,(B)
SKOTT TT,LS
JRST DEF3L
HLRZ AR2A,(B) ;MAYBE HAS & KEY WORDS?
DEF3B: HLRZ T,(AR2A)
JUMPE T,DEF3X ;NIL doesn't require DEFUN& !!
SKOTT T,SY
JRST DEF4 ;PATTERN MATCHINGS REQUIRE DEFUN&
IRP FL,,[OPTIONAL,REST,AUX]
CAIN T,Q%!FL
JRST DEF4 ;KEYWORDS REQUIRE DEFUN&
TERMIN
DEF3X: HRRZ AR2A,(AR2A)
JUMPN AR2A,DEF3B
DEF3L: MOVEI A,QLAMBDA ;CREATE AN APPROPRIATE LAMBDA-EXPRESSION
PUSHJ P,CONS
MOVEI C,(A)
HRRZ A,(P) ;THE CAR OF THIS IS <SPEC>
MOVEI AR2A,QXPRHSH
JSP T,DFPR2 ;CHECK TO SEE IF ATOM (SKIPS UNLESS SYMBOL)
JRST DEF3A
MOVEM B,(P) ;SAVE THIS FUNNY LIST
CAIN AR1,QMACRO
JRST DEFNER ;FUNNY FORMAT AND MACRO FLAG DON'T MIX
HRRZ B,(B) ;PECULIAR FORMAT: (NAME EXPRNAME ...)
HLRZ AR1,(B)
JUMPE AR1,DEFNER
HRRZ B,(B)
SETO AR2A, ;FOR A 2-LIST, USE "EXPR-HASH" FOR EXPR-HASH PROPERTY,
JUMPE B,DEF3A ; BUT MUST ALSO LOOK IN A DIFFERENT PLACE
HRRZ B,(B)
JUMPE B,DEF5 ;3-LISTS DON'T USE EXPR-HASH FEATURE
HLRZ AR2A,(B) ;4-LISTS USE THE FOURTH ITEM
;EXPR-HASH PROP NAME IN AR2A, OR -1;
; DEFINITION IN C; PROPERTY NAME IN AR1; NAME IN CAR OF (P).
DEF3A: SKIPN VDEFUN ;THE VALUE OF DEFUN CONTROLS
JRST DEF5 ; THE EXPR-HASH HACK
HLRZ A,@(P)
JUMPGE AR2A,DEF6 ;JUMP UNLESS 2-LIST FORMAT
MOVEI B,(AR1) ;MUST GET VALUE OF EXISTING PROPERTY
PUSHJ P,GET1 ; AND SEARCH IT FOR THE EXPR-HASH PROPERTY
JUMPE A,DEF5 ;IF NONE, LOSE
JSP T,STENT
TLNN TT,SY ;NO EXPR-HASH IF NOT A SYMBOL
JRST DEF5
MOVEI AR2A,QXPRHSH
;A HAS THE ATOM CONTAINING THE EXPR-HASH PROPERTY, IF ANY.
;AR2A HAS AN ACTUAL EXPR-HASH PROPERTY NAME.
DEF6: MOVEI B,(AR2A)
MOVEI AR2A,(A) ;SAVE ATOM INVOLVED
PUSHJ P,GET1 ;GET EXPR-HASH PROPERTY
JUMPE A,DEF5 ;DO DEFUN IF NONE
MOVE F,(A) ;EXPR-HASH PROPERTY VALUE BETTER BE FIXNUM!
PUSHJ FXP,SAV5M1
MOVEI A,(C) ;CANONICAL LAMBDA FORM
PUSHJ P,SXHASH+1 ;NCALL 1,.FUNCTION SXHASH
PUSHJ FXP,RST5M1
CAMN TT,F
JRST DEF9 ;AHA! HASHES MATCH! FORGET IT.
MOVEI A,(AR2A) ;HASHES MATCH, SO FLUSH THE EXPR-HASH PROPERTY
PUSHJ P,REMPROP ; AND THEN PERFORM THE DEFINITION
;THE CAR OF (P) IS THE ATOM TO PUTPROP ONTO; AR1 IS THE PROPERTY NAME; C IS THE VALUE.
DEF5: HLRZ A,@(P)
EXCH C,AR1
MOVEI B,(C)
JRST DEF1 ;GO DO THE PUTPROP
DEF4: POPI P,1
POP P,B
MOVEI A,Q%DEFUN ;"DEFUN&"
PUSHJ P,CONS ;TRY AGAIN WITH (DEFUN FOO ...) REPLACED BY
JRST EV0 ; (DEFUN& FOO ...)
;TYIPEEK $$PEEK TYPK1 TYPK1C TYPK1F TYPK1H TYPK3 TYPK3C TYPK4 TYPK5 TYPK6 TYPK9 TYPK9A
SUBTTL TYIPEEK FUNCTION
TYIPEEK: ;LSUBR (0 . 3) NCALLABLE
SKIPA F,CFIX1
MOVEI F,CPOPJ
MOVEI D,QTYIPEEK
CAMGE T,XC-3
JRST WNALOSE
SKIPE T ;NO ARGS <=> ONE ARG OF NIL
AOSA T ;ELSE DECREMENT ARG COUNT FOR INCALL
PUSH P,R70
MOVEI D,(P)
ADDI D,(T)
MOVEI AR2A,CPOPJ
EXCH AR2A,(D)
JSP D,XINCALL ;PROCESS ARGS 2 AND 3
SFA% QTYIPEEK ; (ALSO PUSHES F ONTO P)
SFA$ [SO.TIP,,],,QTYIPEEK
MOVEI A,Q%TYI
HRLZM A,BFPRDP
MOVEI A,(AR2A) ;GET ARG 1 IN A
JSP T,GTRDTB ;GET READTABLE IN AR2A
JUMPN A,TYPK1 ;NIL => ACCEPT ANY CHAR
$$PEEK: HRRZ TT,TYIMAN ;CALL TYIMAN ONE EARLY TO
JRST -1(TT) ; SPECIFY PEEKING
TYPK1: CAIE A,TRUTH ;T => SEARCH FOR READER START
JRST TYPK3 ; CHARACTER (E.G. PAREN, MACRO)
TYPK1C: PUSHJ P,$$PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9A ;HIT EOF - TAKE A "SOFT" EOF, RETURN -1
MOVE T,@TTSAR(AR2A) ;PEEK SETS UP AR2A
TLC T,4040 .SEE SYNTAX
TLCE T,4040
JRST TYPK1F
PUSH P,T
PUSHJ P,@TYIMAN
POP P,T
CALLF 0,(T) ;HIT A HORRIBLE SPLICING MACRO
JRST TYPK1C ;GO BACK AND TRY AGAIN
TYPK1F: TLNE T,266217 .SEE SYNTAX ;READER START CHARS
POPJ P,
TYPK1H: PUSHJ P,@TYIMAN ;CHAR NOT ACCEPTABLE - GOBBLE IT
JRST TYPK1C ;NOW GO TRY AGAIN
TYPK3: JSP T,FXNV1 ;ARG MUST BE FIXNUM
JUMPL TT,TYPK3C ;ARG BETWEEN 0 AND 777 =>
CAIG TT,777 ; SCAN FOR THAT CHARACTER;
TLOA TT,400000 ; OTHERWISE IS A SYNTAX, LSH'ED
TYPK3C: LSH TT,-11 ; LEFT BY 11, TO SERVE AS MASK
PUSH FXP,TT
TYPK4: PUSHJ P,$$PEEK ;PEEK AT A CHAR
JUMPL TT,TYPK9 ;SOFT EOF - GO RETURN -1 OR WHATEVER
SKIPL D,(FXP) ;SKIP IF SPECIFIC CHARACTER
JRST TYPK6
CAIN TT,(D) ;COMPARE TO ONE WE GOT
JRST POPXTJ ;SUPER WIN
TYPK5: PUSHJ P,@TYIMAN ;NOT THE ONE - GOBBLE AND RETRY
JRST TYPK4
TYPK6: HLRZ T,@TTSAR(AR2A) .SEE SYNTAX
TDNN T,D ;CHECK SYNTAX AGAINST MASK
JRST TYPK5
JRST POPXTJ
TYPK9: SUB FXP,R70+1
TYPK9A: SKIPN EOFRTN ;"SOFT" EOF. DOES NOT INVOKE
JRST M1TTPJ ; THE EOFFN, BUT WILL PICK UP
JRST EOF9 ; THE EOFVAL IF NECESSARY.
;QUIT VALRET VALSTR VLRT2 VALS1 VALERR
SUBTTL QUIT, VALRET, AND SUSPEND FUNCTIONS
QUIT: MOVEI D,QQUIT ;LSUBR (0 . 1)
AOJL T,S1WNALOSE
SKIPE T
TDZA A,A ;NO ARG => USE NIL
POP P,A
CAIN A,TRUTH ;T MEANS KILL AS QUIETLY AS POSSIBLE
JRST VLRT3
MOVEI D,160000 ;VANILLA-FLAVORED KILL
CAIN A,Q$ERROR ;ERROR MEANS WE SHOULD KILL INPUT BUFFER
TRZ D,100000
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,FX
MOVE D,(A) ;FIXNUM ARG => USE FOR .BREAK 16, ARG
JRST VLRT3A
VALRET: JUMPE T,VLRT9 ;LSUBR (0 . 1)
JSP TT,LWNACK
LA01,,QVALRET
POP P,A
PUSHJ P,VALSTR
IT$ SETOM SAWSP
PUSHJ P,RETVAL ;VALRET STRING ON FXP IN APPROPRIATE MANNER
IT$ SETZM SAWSP
10$ EXIT 1,
20$ WARN [TWENEX VALRET EXIT?]
POPJ P,
;;; TAKE SYMBOL OR FIXNUM IN A, PUSH PNAME STRING OR VALUE ONTO FXP.
;;; ON TOP OF THAT, AS LAST FXP SLOT, PUSH ORIGINAL VALUE OF FXP.
VALSTR: JSP T,LATOM ;STRING A SYMBOL?
JRST VALS1
IT$ SETZM VALFIX ;FLAG THAT VALRET 'STRING' IS NOT A FIXNUM
PUSHJ P,PNGET
MOVE R,FXP
VLRT2: HLRZ B,(A)
PUSH FXP,(B)
HRRZ A,(A)
JUMPN A,VLRT2
PUSHN FXP,1 ;PUSH A ZERO WORD FOR GOOD MEASURE
PUSH FXP,R
POPJ P,
VALS1:
IFN ITS,[
SKOTT A,FX ;ALLOW A FIXNUM
JRST VALERR ;ERROR -- WTA
SETOM VALFIX ;REALLY A FIXNUM
MOVE R,FXP ;SAVE A COPY OF FXP
PUSH FXP,(A) ;PUSH THE FIXNUM
PUSH FXP,R ;THEN PUSH THE OLD FXP
POPJ P,
] ;END IFN ITS
VALERR:
IT$ WTA [- ARG TO BE VALRET'ED MUST BE A FIXNUM OR A SYMBOL!]
IT% WTA [- ARG TO BE VALRET'ED MUST BE A SYMBOL!]
JRST VALSTR
;RETVAL RETSTR VLRT1 VLRT5 VLRT3 VLRT3A VLRT9 SIDDTP VLRT9
;;; ASSUME VALSTR HAS PUSHED A VALRET STRING ONTO FXP.
;;; VALRET THAT STRING IN THE APPROPRIATE MACHINE-DEPENDENT WAY,
;;; EXCEPT THAT CERTAIN "ITS" STRINGS ARE INTERPRETED IN ANY
;;; IMPLEMENTATION (AN ANACHRONISM FOR COMPATIBILITY ONLY).
;;; AFTER DOING WHATEVER, THE STRING IS FLUSHED FROM FXP.
RETVAL:
IFN ITS,[
SKIPN VALFIX ;WAS VALRET STRING REALLY A FIXNUM?
JRST RETSTR ;NO, NORMAL HANDLING
HRRZ TT,-1(FXP) ;YES, PICK UP THE FIXNUM
.BREAK 16,(TT)
MOVE FXP,(FXP) ;RESET FXP
POPJ P, ;IF CONTINUING RETURN AND GO ON
RETSTR: ] ;END IFN ITS
MOVE R,(FXP)
MOVE D,1(R)
CAME D,[ASCII \:KILL\]
CAMN D,[ASCII \:kill\]
CAIA
JRST VLRT1
MOVE D,2(R)
CAME D,[ASCII \ \]
CAMN D,[ASCII \
\]
JRST VLRT3
JRST VLRT5
VLRT1: CAMN D,[ASCII \≠_.\]
JRST VLRT3
CAME D,[ASCII \≠≠U\]
CAMN D,[ASCII \≠≠u\]
IT$ .LOGOUT
.ELSE XCT VLRT9
;HERE IS THE MACHINE-DEPENDENT THING TO DO TO RET THE VAL STRING
VLRT5:
IT$ .VALUE 1(R)
IFN D10,[
SA% OUTSTR 1(R)
IFN SAIL,[
SETZ D, ;D IS ZERO FOR TWO DIFFERENT REASONS!
MOVEI TT,1(R) ;THIS PIECE OF CRAP LOOKS LIKE
HRLI TT,440700 ; SOMETHING RPG WOULD WRITE (BUT GLS DID)
ILDB T,TT
JUMPN T,.-1
MOVEI T,↑M ;CRUFTY STRAY ↑M MAKES PTLOAD HAPPIER
DPB T,TT
IDPB D,TT ;THEN TERMINATE WITH A NULL
HRLI R,440700
HRRI R,1(R)
PTLOAD D ;LOAD THE STRING INTO THE LINE EDITOR
] ;END OF IFN SAIL
] ;END OF IFN D10
20$ WARN [VALRET IN TWENEX?]
MOVE FXP,(FXP)
POPJ P,
VLRT3:
IT$ MOVEI D,120000 ;"SILENT KILL"
VLRT3A:
10$ EXIT 1,
20$ HALTF
10X WARN [HOW TO EXIT IN TENEX]
IFN ITS,[
.LOGOUT ;TRY TO LOG OUT
JSP T,SIDDTP
.VALUE
.BREAK 16,(D)
VLRT9: .LOGOUT ;TRY TO LOG OUT
.VALUE [ASCIZ \:VK \] ;OH, WELL...
POPJ P, ;IN CASE LOSER DOES $P FROM IT
SIDDTP: .SUSET [.ROPTION,,TT]
TLNN TT,OPTBRK ;SKIP IF JOB INFERIOR TO DDT
JRST (T) ; (ACTUALLY, IF SUPERIOR HANDLES .BREAK)
JRST 1(T)
] ;END OF IFN ITS
IFE ITS,[
VLRT9:
10$ EXIT 1,
20$ HALTF
POPJ P,
];END IFE ITS
;SUSPEND SUSP0C SUSPGC SUSP0 SUSP0E SUSGC1 SUSP11 SUSP12 SUSP1 SUSP14 FLSNOT SUSP24 SUSP24 SUSP25 SUSP24 SUSP25 SUSP3
SUSPEND: ;LSUBR (0 . 2)
JSP TT,LWNACK
LA012,,QSUSPEND
IT$ SETZM PURDEV ;ASSUME NO DUMPING
PUSH FLP,R70 ;ASSUME WE ARE RETURNING FROM A RESTART
PUSH FLP,R70 ;ALSO ASSUME FIRST ARG IS NON-NIL
JUMPE T,SUSP0
AOJE T,SUSP0C ;JUMP IF ONE ARG
POP P,A ;2ND ARG, IF ANY, IS SAVE FILE NAME FOR HISEG
; FOR ITS, IS NAME OF PDUMP FILE
IFN D10*HISEGMENT,[
SKIPN SUSFLS
JRST SUSP0C
PUSHJ P,FIL6BT ;CONVERT FILESPEC IN A TO SIXBIT ON FXP
PUSHJ P,DMRGF ;MERGE WITH DEFAULTS
POP FXP,SGAEXT ;UNSTACK ARGS INTO PROPER SPOT
POP FXP,SGANAM
POP FXP,SGAPPN
POP FXP,SGADEV
PUSHJ P,SAVHGH ;SAVE HIGH SEGMENT
FAC [FAILED TO SAVE HIGH SEGMENT - SUSPEND!]
] ;END OF IFN D10*HISEGMENT
IFN ITS,[
PUSHJ P,FIL6BT ;CONVERT FILESPEC IN A TO SIXBIT ON FXP
PUSHJ P,DMRGF ;MERGE WITH DEFAULTS
POP FXP,PURFN2 ;UNSTACK ARGS INTO PROPER SPOT
POP FXP,PURFN1
POP FXP,PURSNM
POP FXP,PURDEV
] ;END IFN ITS
SUSP0C: POP P,A ;POP FIRST ARGUMENT
SKIPN A ;FIRST ARG NIL?
AOSA (FLP) ;YES, NO VALRET STRING
PUSHJ P,VALSTR ;NO, PROCESS IT ONTO FXP
JRST SUSP0E
SUSPGC: 666666,,SUSGC1 ;GARBAGE COLLECTOR STACK WORD
SUSP0: PUSH FXP,R70 ;ZERO WORD MEANS VALRET STRING
SUSP0E: PUSH P,SUSPGC
JRST AGC
SUSGC1: SETZ A,
MOVEI T,LCHNTB
SUSP11: SOJE T,SUSP12
SKIPE B,CHNTB(T)
CAMN B,V%TYI
JRST SUSP11
CAMN B,V%TYO
JRST SUSP11
MOVE TT,TTSAR(B) ;IF FILE IS CLOSED THEN IGNORE IT
TLNN TT,TTS.CL
PUSHJ P,XCONS
JRST SUSP11
SUSP12: JUMPN A,SUSPE
HRRZ A,V%TYI ;CLOSE THE TTYS LAST, SO THEY WONT CAUSE
PUSHJ P,$CLOSE ;SPURIOUS "CANT SUSPEND -I/O IN PROGRESS"
HRRZ A,V%TYO
PUSHJ P,$CLOSE
SUSP1: HRROS NOQUIT
MOVEM NIL,GCNASV+1
MOVE T,[FREEAC,,GCNASV+2]
BLT T,GCNASV+2+17-FREEAC
SETOM NOPFLS
IFN ITS,[
IFN USELESS,[
MOVE T,IMASK
TRNN T,%PIMAR
JRST SUSP14
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70]
SUSP14:
] ;END OF IFN USELESS
.SUSET [.SSNAM,,IUSN]
SETOM SAWSP
MOVEI T,FLSST
EXCH T,LISPSW
MOVEM T,GCNASV
SKIPE SUSFLS ;IF FLUSHING PURE PAGES PROCESS VALRET THEN
JRST FLSLSP
FLSNOT: PUSHJ P,PDUMPL ;PURE DUMP LISP IF APPROPRIATE
MOVEI T,SUSP3 ;FROM HERE ON IN START AT SUSP3 DIRECTLY
MOVEM T,LISPSW
SKIPE (FLP) ;NIL JCL?
JRST SUSCON ;YES, CONTINUE ON AND RETURN T
SKIPN (FXP) ;ZERO WORD MEANS NO VALRET STRING
JRST SUSP24
PUSHJ P,RETVAL
JRST SUSCON
SUSP24: MOVE T,FXP
POPI T,1
MOVEM T,(FXP)
.VALUE FLSPA1 ;PRINT SUSPENSION MESSAGE ":≠Suspended≠"
JRST SUSCON
] ;END OF IFN ITS
IFN D20,[
MOVEI T,SUSP3
EXCH T,LISPSW
MOVEM T,GCNASV
SKIPE (FLP) ;NIL JCL?
JRST SUSCON ;YES, PROCEED
SKIPN 1,(FXP)
JRST SUSP24
HRROI 1,1(1)
JRST SUSP25
SUSP24: MOVE T,FXP
POPI T,1
MOVEM T,(FXP)
HRROI 1,[ASCIZ\
;Suspended
\]
SUSP25: PSOUT
HALTF
] ;END OF IFN D20
IFN D10,[
HRRZ T,.JBSA"
HRL T,.JBREN"
MOVEM T,GCNASV
MOVE T,.JBREL ;GET HIGHEST ADR WE NEED TO SAVE
HRLM T,.JBSA ;AND STORE IN CORRECT PLACES SO MONITOR KNOWS
MOVEM T,.JBFF
MOVEI T,SUSP3
HS% HRRM T,.JBSA
HS$ HRRM T,RETHGH
SKIPE (FLP) ;NIL JCL?
JRST SUSCON ;YES, CONTINUE AND RETURN T
SKIPN (FXP)
JRST SUSP24
SA$ PUSHJ P,RETVAL ;PTLOAD VALRET STRING FOR SAIL
JRST SUSP25
SUSP24: MOVE T,FXP
POPI T,1
MOVEM T,(FXP)
SUSP25: OUTSTR [ASCIZ \
;$Suspended$
\]
HS$ JRST KILHGH
IFE HISEGMENT,[
IFN SAIL,[
MOVEI A,FAKDDT ;FOO, HOW MANY WAYS CAN SAIL LOSE?
SKIPN .JBDDT ; JOBDDT MUST BE NON-ZERO TO SAVE!
SETDDT A, ; OTHERWISE MAY FAIL TO SAVE ENTIRE LOSEG
] ;END IFN SAIL
EXIT 1,
] ;END IFE HISEGMENT
] ;END OF IFN D10
;;; HERE ON STARTUP AGAIN AFTER SUSPENSION
SUSP3: MOVE NIL,GCNASV+1 ;RESTORE IMPORTANT AC'S
MOVE T,[GCNASV+2,,FREEAC]
BLT T,17
SETZB A,B ;CLEAR OUT GARBAGE
SETZB C,AR1
SETZ AR2A,
SKIPN (FLP) ;RESTORE FXP UNLESS JCL WAS NIL
MOVE FXP,(FXP)
IFN ITS+D20,[
MOVE T,GCNASV
MOVEM T,LISPSW
IFN ITS,[
JSP T,SHAREP ;RE-READ PURE PAGES IF EVERYTHING IS IN ORDER
.SUSET [.ROPTION,,TT]
TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
.SUSET [.SOPTION,,TT]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
.SUSET [.SMASK,,IMASK]
.SUSET [.SMSK2,,IMASK2]
IFN USELESS,[
MOVE T,IMASK
TRNE T,%PIMAR
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN USELESS
] ;END OF IFN ITS
] ;END OF IFN ITS+D20
IFN D10,[
MOVE T,GCNASV
HRRM T,.JBSA"
HLRM T,.JBREN
IFE SAIL,[
JSP T,D10SET
GETPPN TT,
JFCL
] ;END OF IFE SAIL
SA$ SETZ TT,
SA$ DSKPPN TT, ;AS SET BY ALIAS
MOVEM TT,USN
PION
PUSHJ P,SIXJBN
] ;END OF IFN D10
IFN D20,[
JSP T,TNXSET ;MUST BE DONE BEFORE PION
PION
] ;END IFN D20
SETZM NOPFLS
HRRZS NOQUIT
IT$ MOVE TT,IUSN ;IUSN WAS SET UP BY LISPGO
IT$ MOVEM TT,TTYIF2+F.SNM
IT$ MOVEM TT,TTYOF2+F.SNM
10$ MOVE TT,USN
10$ MOVEM TT,TTYIF2+F.PPN
10$ MOVEM TT,TTYOF2+F.PPN
PUSH FXP,TT
PUSHJ P,OPNTTY ;*** TEMP CROCK?
JFCL
PUSH FXP,R70
MOVEI A,-1(FXP)
HRLI A,440600
IT$ PUSHJ P,READ6C
SA% 10$ PUSHJ P,SUNAME
IFN SAIL,[
SETZ TT,
DSKPPN TT, ;PPNATM REQUIRES ARG IN TT
PUSHJ P,PPNATM
] ;END IFN SAIL
SUB FXP,R70+2
IFN D20,[
JSP T,TNXUDI
PUSHJ P,PNBFAT ;CONVERT PNBUF TO AN ATOM
] ;END IFN D20
MOVEM A,SUDIR
POPI FLP,1 ;REMOVE NIL VALRET FLAG
POP FLP,A ;RESTORE RETURN VALUE
POPJ P,
;SAVHGH SAPWIN
SUBTTL HIGH SEGMENT SAVE ROUTINE
IFN D10,[
;;; THE RELEVANT FILE NAMES ARE IN SGADEV, SGAPPN, SGAEXT.
;;; THE MAIN FILE NAME IS PASSED THROUGH T, AND STORED INTO
;;; SGANAM ON SUCCESS. SKIP RETURN ON SUCCESS.
IFN HISEGMENT,[
SAVHGH: LOCKI ;LOCK OUT INTERRUPTS AROUND USE OF TEMP CHANNEL
MOVE F,SGANAM
IFN SAIL,[
SKIPL .JBHRL ;IS HISEG CURRENTLY WRITE-PROTECTED?
JRST SAPWIN ;NO, MUST PREVIOUSLY HAVE UNPURIFIED IT
SKIPN PSGNAM
JRST FASLUH
MOVEI T,.IODMP
MOVE TT,PSGDEV
SETZ D,
OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE
JRST FASLUH
MOVE T,PSGNAM
MOVE TT,PSGEXT
SETZ D,
MOVE R,PSGPPN
LOOKUP TMPC,T
JRST FASLUR
MOVS T,R
MOVNS T ;T GETS LENGTH OF .SHR FILE
ADDI T,400000-1
PUSHJ P,LDRIHS ;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!)
RELEASE TMPC, ;FLUSH TEMP CHANNEL
MOVE T,D10NAM ;USE D10NAM AS HISEG NAME TO FOIL SHARING
LSH T,-6 ;AS LONG AS WE'RE BEING RANDOM...
SETNM2 T,
JFCL
MOVE F,SGANAM ;RESTORE MAIN FILE NAME
SAPWIN:]
SETZM SGANAM
MOVE R,SGADEV
IFN SAIL,[
;;;SAVE VALIDATION WORDS IN HISEG, HOPE THAT HISEG WRITEABLE
MOVEM R,PSGDEV
MOVE D,SGAEXT
MOVEM D,PSGEXT
MOVE D,SGAPPN
MOVEM D,PSGPPN
] ;END OF IFN SAIL
MOVEI D,.IODMP
MOVE T,F ;SGANAM WAS SAVED IN F
SETZ F,
OPEN TMPC,D
UNLKPOPJ
MOVE TT,SGAEXT
SETZ D,
MOVE R,SGAPPN
SA$ MOVEM T,PSGNAM
ENTER TMPC,T
UNLKPOPJ
MOVEI TT,400000-1 ;MAKE UP IOWD
SUB TT,.JBHRL
MOVSS TT
HRRI TT,400000-1
SETZ D,
OUT TMPC,TT ;OUTPUT THE HISEG
CAIA
UNLKPOPJ
CLOSE TMPC, ;FLUSH TEMP CHANNEL
RELEASE TMPC,
MOVEM T,SGANAM ;WE CAREFULLY DO NOT STORE SGANAM UNTIL
UNLOCKI ; WE HAVE CLEARLY WON (MORE OR LESS)
JRST POPJ1
] ;END IFN HISEGMENT
] ;END OF IFN D10
;ARGS ARGS1 ARGS1A ARGSCU ARGSC1 ARGS3 ARGS5 ARGS6 ARGCLB ARGCL3 ARGS0
SUBTTL ARGS FUNCTION
ARGS: JSP TT,LWNACK ;LSUBR (1 . 2) - USES A,B,C,T,TT,D,R,F
LA12,,QARGS
JSP R,PDLA2(T) ;SPREAD ARGS
ARGS1: SKOTT A,SY
JRST ARGS0 ;FIRST ARG MUST BE SYMBOL
HLRZ F,(A)
ARGS1A: AOJL T,ARGS3 ;TWO ARGS
HLRZ R,1(F) ;JUST WANT TO GET PRESENT ARGS PROP
ARGSCU: JUMPE R,FALSE ;ARGS CONS-UP
IDIVI R,1000
SKIPN B,F
JRST ARGSC1
MOVEI TT,-1(F)
JSP T,FIX1A
MOVEI B,(A)
ARGSC1: SKIPN A,R
JRST CONS
MOVEI TT,(R)
CAIE TT,777
SUBI TT,1
JSP T,FIX1A
JRST CONS
ARGS3: JUMPE A,CPOPJ
JUMPN B,ARGS5
HLRZ R,1(F) ;JUST WANT TO FLUSH ARGS PROP
JUMPE R,FALSE
SETZ R,
PUSH P,A
JSP D,ARGCLB
SUB P,R70+1
JRST TRUE
ARGS5: PUSH P,A
SETZB TT,R
HLRZ C,(B) ;MUMBLE MUMBLE - MUST FIGURE
JUMPE C,ARGS6 ; OUT WHATEVER WE WERE HANDED
JSP T,FXNV3
CAIE R,777
ADDI R,1
LSH R,11
ARGS6: HRRZ A,(B)
JSP T,FXNV1
CAIE TT,777
ADDI TT,1
ADDI R,(TT)
HLRZ TT,1(F) ;LOOK AT ARGS PROP ALREADY THERE
CAIN TT,(R) ;IF ALREADY WHAT WE WANT, JUST EXIT,
JRST POPAJ ; THEREBY AVOIDING A PURE PAGE TRAP
MOVEI D,POPAJ ;FAKE OUT A JSP D,
ARGCLB: MOVEI B,(F) ;CLOBBER IN AN ARGS PROPERTY
ARGCL3:
PURTRAP ARGCL7,B, HRLM R,1(B) ;MAY HAVE TO FUSS ABOUT PURE PAGE TRAP
JRST (D)
ARGS0: MOVEI F,$$$NIL
JUMPE A,ARGS1A
WTA [ NON-SYMBOL - ARGS!]
JRST ARGS1
;EVALFRAME FRM2A FRM3 FRM3A FRM4A FRM4 FRM5 FRM5A FRM7 FRM8 FRM2B
SUBTTL EVALFRAME FUNCTION, GTPDLP, AND FRETURN
EVALFRAME:
SKIPA R,[GTPDLP] ;THIS ENTRY CAUSES INTERPRETATION OF ARG AS PDLPOINTER
FRM2A: MOVEI R,GTPDL2 ;THIS ENTRY, TO ALLOW CONTINUING FROM WHERE D CURRENTLY IS
JSP R,(R)
$EVALFRAME ;GET EVALFRAME OR APPLYFRAME JUST PRIOR TO
$APPLYFRAME ; POINT ON PDL MARKED BY ARG
JRST FALSE
FRM3: SUB D,R70+1 ;DEFINE A FRAME POINTER TO BE JUST BELOW THE EVALFRAME MARKER
HRRZ TT,(D)
JUMPN F,FRM3A ;F IS INDEX OF WHICH KIND OF FRAME
MOVEI T,(TT)
LSH T,-SEGLOG
SKIPL ST(T)
JRST FRM4A
HLRZ TT,(TT)
FRM3A: CAIN TT,QEVALFRAME ;DONT ALLOW THE CALL TO EVALFRAME
JRST FRM2B ; ITSELF TO BE OUTPUT
FRM4A: PUSH P,(D)
FRM4: ;ERRFRAME COMES HERE
HLRO TT,(D) ;ONE LEFT HALF'S AS GOOD AS ANOTHER...
JSP T,FIX1A ;MAKE UP PREVIOUS SPECIAL PDL POINTER
PUSHJ P,ACONS
EXCH B,(P)
MOVE TT,1(D)
CAME TT,[$APPLYFRAME]
JRST FRM8
PUSH P,A
PUSH P,B
MOVE T,-2(D) .SEE $APPLYFRAME ;BECAUSE THERE IS A DISCUSSION
JUMPL T,FRM5 ; OF THE FRAME FORMAT THERE
MOVEI A,(T)
TLCN T,-1 ;THINK ABOUT THIS WHEN YOU LOOK!
JRST FRM7
HLRS T ;SUBTLE WAY TO GET NEGATION
ADDI T,(D)
FRM5: SETZ A,
FRM5A: HRRZ B,(T)
PUSHJ P,XCONS
AOBJN T,FRM5A
PUSHJ P,NREVERSE
FRM7: PUSHJ P,ACONS
POP P,B
PUSHJ P,XCONS
MOVEI B,(A)
POP P,A
FRM8: PUSHJ P,XCONS
MOVE B,A ;OUTPUT 4-LIST: "EVAL" OR "APPLY" OR "ERR" [A SYMBOL]
HRROI TT,(D) ; FRAME (REGPDL) POINTER [A FIXNUM]
JSP T,FIX1A ; <FORM> [EVAL] OR (<FN> <ARGS>) [APPLY]
PUSHJ P,CONS ; OR <MSG-FORM> [ERR]
MOVE TT,1(D) ; ALIST (SPECPDL) POINTER [A FIXNUM]
MOVEI B,QOEVAL
CAMN TT,[$APPLYFRAME]
MOVEI B,QAPPLY
CAMN TT,[$ERRFRAME]
MOVEI B,QERR
PUSHJ P,XCONS
JRST POPBJ
FRM2B: TLNE R,1
ADD D,R70+2 ;WHEN SEARCHING FORWARD, SKIP OVER CALL
JRST FRM2A ;TO EVALFRAME
;GTPDLP GTPDL5 GTPDL2 GTPDL3 GTPDL4 GTP4A GTPX0 GTPX1
GTPDLP: ;CALLED BY JSP R,GTPDLP; RETURNS PDL PTR IN D
MOVEI D,(P)
JUMPE A,GTPDL2 ;ARG=NIL => START SEARCH FROM CURRENT PDL POS
JSP T,FXNV1 ;NOTE: EVALFRAME LOOKS AT BIT 3.1 OF R
JUMPL TT,GTPDL5 ;BIT 3.1 OF R = 0 WHEN SEARCHING BACK THE PDL
TLO R,1 ;BIT 3.1 OF R = 1 WHEN SEARCHING FORWARD
MOVNS TT ;WANT TO SKIP OVER THE FRAME MARKER WHEN
SKIPN TT ; SEARCHING FORWARD (SINCE A PDLPOINTER WILL
SKIPA TT,C2 ; BE POINTING TO ONE BELOW A FRAME MARKER)
ADD TT,R70+2
GTPDL5: TLZ TT,-1
HRRZ T,C2
CAIGE TT,(T)
JRST GTPDL1
MOVEI T,(P)
SUBI T,(TT)
JUMPLE T,GTPDL1
MOVEI T,(TT)
CAIL T,(P)
MOVE TT,P
HRROI D,(TT)
GTPDL2: MOVE TT,(R) ;KEY ON WHICH TO SEARCH
JUMPE TT,2(R) ;MATCH 0 => NO SEARCH, JUST GIVE OUT PDL PTR
MOVE F,1(R) ;WELL, IT'S POSSIBLE TO SEARCH FOR TWO THINGS
TLNE R,1
JRST GTPDL4
HRRZ T,C2
GTPDL3: CAIL T,(D) ;A BACK SEARCH
JRST 2(R) ;SEARCHED-AND-FAILED EXIT
CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
SOJA D,GTPDL3
GTPDL4: MOVEI T,(P)
GTP4A: CAMN TT,(D)
JRST GTPX0
CAMN F,(D)
JRST GTPX1
CAIG T,(D)
JRST 2(R) ;FAILURE
AOJA D,GTP4A
GTPX0: TDZA F,F
GTPX1: MOVEI F,1
JRST 3(R)
;FRETURN FRETRY FRETR1 FRP1 FRP2 FRP2A FRP4 FRP3 FRP3QA
FRETURN: TDZA C,C ;LH OF C REMEMBERS WHICH ENTRY
FRETRY: MOVSI C,TRUTH
HRR C,B
JSP R,GTPDLP
0
JFCL
MOVEI F,(D)
MOVE TT,[$EVALFRAME]
CAMN TT,1(F)
JRST FRETR1
MOVE TT,[$APPLYFRAME]
CAME TT,1(F)
JRST FRERR
FRETR1: MOVEI D,(F)
SUBI D,(P)
HRLI D,(D)
HRRI D,(F)
MOVE TT,[$UIFRAME]
CAME TT,(D) ;SEARCH FOR A USER INTERRUPT FRAME
AOBJN D,.-1
CAMN TT,(D)
JSP TT,UIBRK
FRP1: SKIPE T,PA4 ;BREAK UP A DOMINEERING PROG
CAIL F,(T) ;[WHICH BREAKS UP INTERIOR ERRSETS AND CATCHES]
JRST FRP2
MOVEI TT,FRP1-1 ;FAKE OUT RETURN BY INSERTING A RETURN-ADDRESS
MOVEM TT,-LPRP+1(T) ;OF FRP1 ON THE PDL
JRST RETURN
FRP2: SKIPE B,ERRTN ;BREAK UP A DOMINEERING ERRSET
FRP2A: CAIL F,(B)
JRST FRP4
MOVEI T,FRP1
MOVEI TT,FRP1
JRST BKRST0
FRP4: SKIPE B,CATRTN ;BREAK UP A CATCH
CAIL F,(B)
JRST FRP3
MOVEI T,FRP1 ;IN CASE OF UNWIND-PROTECT
MOVEI TT,FRP1
JRST BKRST0
FRP3: SKIPN B,EOFRTN ;BREAK OUT OF ANY E-O-F SET READS
JRST FRP3QA
CAIGE F,(B)
JRST FRP2A
FRP3QA: MOVEI A,(C)
IFE PAGING,[
ADDI F,1 ;FIX UP PDL POINTERS
SUB F,C2
HRLS F
ADD F,C2
MOVE P,F
HRRZ F,-2(P)
SUB F,FXC2
HRLS F
ADD F,FXC2
MOVE FXP,F
HLRZ F,-2(P)
SUB F,FLC2
HRLS F
ADD F,FLC2
MOVE FLP,F
] ;END OF IFE PAGING
IFN PAGING,[ ;IN A PAGED SYSTEM, THE PDLOV HANDLER
HRROI P,1(F) ; WILL FIX UP THE LHS OF THE PDL PTRS
HLRO FLP,-2(P)
HRRO FXP,-2(P)
] ;END OF IFN PAGING
HLRZ TT,-1(P)
TLNN C,-1 ;FOR "FRETURN" JUST UNBIND TO MARKED
JRST UBD ; POINT, AND POP FRAME
PUSHJ P,UBD
HLRZ TT,(A) ;BUT DO MORE FOR "FRETRY", AFTER UBD
JSP T,%CADDR
POPI P,L$EVALFRAME ;GET RID OF BASIC EVALFRAME
CAIE TT,QAPPLY
JRST EVAL
HRRZ B,(A)
HLRZ B,(B)
HLRZ A,(A)
HLRE T,(P) ;GET RID OF ARGS ON APPLYFRAME
SKIPG T ;FIGURE OUT LENGTH OF ARGS PART
MOVEI T,1
HRLI T,(T)
SUB P,T
JRST .APPLY
;$GETCHARN GETCHAR GETCH1 GETCH2 GETCH3 GETCH4 GETCH8 GTCTB SUBLIS SUBLSA SUBL1 SUBL1B SUBL1A SUBLOSE SUBL3Q SUBL3Z
SUBTTL GETCHAR, GETCHARN, AND SUBLIS
$GETCHARN: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE
SKIPA F,[ZPOPJ,,CPOPJ]
GETCHAR: MOVE F,[FALSE,,RDCH2] ;SUBR 2
SKIPE V.RSET
JRST GETCH8
MOVE D,(B)
PUSHJ P,PNGT0
GETCH1: SOJL D,(F)
IDIVI D,5 ;(Q,R) QUOTIENT,REMAINDER IN D,R
SOJL D,GETCH3
GETCH2: HRRZ A,(A) ;CDR BY Q WORDS
SOJGE D,GETCH2 ;RECALL THAT (CDR NIL) = NIL
JUMPE A,GETCH4
GETCH3: HLRZ A,(A)
LDB TT,GTCTB(R)
JUMPN TT,(F)
GETCH4: MOVS F,F
JRST (F)
GETCH8: JSP T,FXNV2
PUSHJ P,PNGET
JRST GETCH1
GTCTB: 350700,,(A)
260700,,(A)
170700,,(A)
100700,,(A)
010700,,(A)
SUBLIS: JUMPN A,SUBLSA ;NULL SUBSTITUTION LIST?
MOVE A,B ;YES, RETURN SECOND ARG
POPJ P,
SUBLSA: PUSH P,A ;USES ONLY A,B,T,TT,D,R
PUSH P,B
MOVE D,A
HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE
SUBL1: JUMPE D,SUBL2
HLRZ T,(D) ;A SUBSTITUTION LIST IS LIKE
HLRZ B,(T) ;((U1 . S1) (U2 . S2) . . .)
SKOTT B,SY
JRST SUBLOSE
SUBL1B: HRRZ A,(B) ;SEXPRESSION S IS SUBSTITUTED FOR ATOM U
HLRZ A,(A)
CAIN A,QSUBLIS
JRST SUBL1A
HRRZ A,(T)
MOVEM B,T
HRRZ B,(B)
PUSHJ P,CONS
MOVEI B,QSUBLIS ;PUT "SUBLIS" PROPERTY ON THOSE ATOMS U IN THE
PUSHJ P,XCONS ;SUBSTITUTION LIST ((U1 . V1) . . . (UN . VN))
HRRM A,(T)
SUBL1A: HRRZ D,(D)
MOVE T,INTFLG
AOJGE T,SUBL1 ;0=> NO INT, -1=> USER INT, -2,-3=> QUIT
MOVE R,D
JRST SUBL3Q
SUBLOSE: JUMPE B,SUBL3Z
MOVEI A,(B)
MOVEI R,(D)
MOVEI T,[LER3 [SIXBIT \NON-ATOMIC ITEM - SUBLIS!\]]
MOVEM T,-2(P)
SUBL3Q: SUB P,R70+1
JRST SUBL3A
SUBL3Z: MOVEI B,NILPROPS
JRST SUBL1B
;SUBL2 SUBL3A SUBL3 SUBL4 SBL1 SBL5 SBL4 SBL2 SBL2A SBL2B
SUBL2: POP P,A
PUSHJ P,SBL1
JFCL
MOVEI R,0 ;REMOVE ALL "SUBLIS" PROPERTIES
SUBL3A: MOVE TT,(P)
SUBL3: CAIN R,(TT) ;REMOVE "SUBLIS" PROPERTY
JRST SUBL4
HLRZ T,(TT)
HLRZ T,(T)
JUMPN T,.+2
MOVEI T,NILPROPS
HRRZ B,(T)
MOVE B,(B)
HLRZ D,B
HRRZ B,(B)
CAIN D,QSUBLIS
HRRM B,(T)
HRRZ TT,(TT)
JRST SUBL3
SUBL4: SUB P,R70+1
JRST CZECHI
SBL1: SKOTT A,LS ;TRACE THROUGH STRUCTURE IN (A) SUBSTITUTING
JRST SBL2 ;(GET 'U 'SUBLIS) FOR U WHEREVER IT IS NON-NIL
PUSH P,A
HLRZ A,(A)
PUSHJ P,SBL1
JRST SBL4
EXCH A,(P)
HRRZ A,(A)
PUSHJ P,SBL1
JFCL
HRRZ B,(P)
SBL5: SUB P,R70+1
PUSHJ P,XCONS
JRST POPJ1
SBL4: HRRZ A,@(P)
PUSHJ P,SBL1
JRST POPAJ
HLRZ B,@(P)
JRST SBL5
SBL2: TLNN TT,SY
JRST SBL2B
HRRZ B,(A)
SBL2A: HLRZ T,(B)
CAIE T,QSUBLIS
POPJ P,
HRRZ A,(B)
HLRZ A,(A)
JRST POPJ1
SBL2B: JUMPN A,CPOPJ
HRRZ B,NILPROPS
JRST SBL2A
;SAMEPNAMEP ALPHALESSP ALPL3 ALPLP1 ALPL2 SYSP SYSP3 SYSP6 SYSPZ1 SYSPZ GCTWA GCTWI GCTWX
SUBTTL SAMEPNAMEP AND ALPHALESSP
SAMEPNAMEP: TDZA D,D ;USES ONLY A,B,T,TT,D
ALPHALESSP: MOVEI D,TRUTH ;MUST PRESERVE C,AR1,AR2A,R,F (SEE SORT)
PUSH P,B
PUSHJ P,PNGET
EXCH A,(P)
PUSHJ P,PNGET
POP P,B ;FROM NOW ON, A HAS PNAME OF 2ND ARG, B OF 1ST
JRST ALPLP1
ALPL3: HRRZ A,(A)
HRRZ B,(B)
ALPLP1: JUMPE B,ALPL2
JUMPE A,FALSE ;ON SAMEPN, LOSE IF 2ND ARG RUNS OUT BEFORE 1ST
HLRZ T,(A) ;ON ALPHAL, LOSE IF 2ND ARG IS SHORTER THAN 1ST
MOVE T,(T)
HLRZ TT,(B) ;FOR SAMEPN, WILL RETURN NIL IF
;TWO ARE UNEQUAL IN SOME PLACE
CAMN T,(TT) ;NO INFO IF CORRESPONDING PLACES ARE EQUAL
JRST ALPL3
JUMPE D,FALSE ;BUT NOT EQUAL IN SAMENAMEP MEANS LOSE
MOVE TT,(TT) ;MUST DO SOME HAIR FOR THE ALPHALESSP
LSHC T,-1 ; COMPARE TO WIN, SINCE PNAME WORDS ARE
CAMG T,TT ; LOGICAL DATA, NOT ARITHMETIC
JRST FALSE ;2ND ARG STRICTLY LESS THAN FIRST
JRST TRUE ;2ND ARG STRICTLY GREATER THAN FIRST
ALPL2: EXCH A,D
JUMPE D,NOT ;IF ALPHAL, WIN WHEN A NON-NUL
;[FOR 1ST ARG IS PROPER SUBSTRING OF 2ND]
POPJ P, ;IF SAMEPN, WIN WHEN A NUL
;[FOR CORRESPONDENTS HAVE BEEN EQUAL ALL ALONG]
SYSP: MOVEI B,TRUTH ;SUBR 1 - DETERMINE WHETHER SYMBOL HAS
SYSP3:
10% CAIGE A,BEGFUN ; A "SYSTEM" SUBR PROPERTY
10$ CAIL A,ENDFUN
JRST FALSE
10% CAIG A,ENDFUN
10$ CAIL A,BEGFUN
JRST BRETJ
CAIGE A,BSYSAR ; ... OR MAYBE A SYSTEM ARRAY PROPERTY
JRST SYSP6
CAIGE A,ESYSAR
JRST BRETJ ;RETURNS T FOR SUBR/SAR POINTERS
CAIE B,QAUTOLOAD
JRST SYSP6
CAIL A,BSYSAP
CAIL A,ESYSAP
JRST FALSE
JRST BRETJ
SYSP6: JSP T,SPATOM ;RETURNS FALSE FOR NON-SYMBOLS
JRST FALSE
PUSH P,A ;TRY THE AUTOLOAD PROPERTY FIRST
MOVEI B,QAUTOLOAD
PUSHJ P,GET
JUMPN A,SYSPZ
SYSPZ1: POP P,A
MOVEI B,ASBRL
PUSHJ P,GETL1
JUMPE A,CPOPJ ;RETURNS FALSE FOR SYMBOLS WITH NO FN PROPS
HLRZ B,(A) ;RETURNS NAME OF PROPERTY OF ONE IS FOUND,
JSP T,%CADR
JRST SYSP3 ; AND THE PROPERTY VALUE PASSES THE SYSP TEST
SYSPZ: CAIL A,BSYSAP
CAIL A,ESYSAP
JRST SYSPZ1 ;AUTOLOAD PROPERTY NOT SYSTEM'S - GO ON
POP P,A ;ELSE FLUSH STACK OF A
MOVEI A,QAUTOLOAD ;AND RETURN AUTOLOAD
POPJ P,
GCTWA: JUMPE A,GCTWI
HLRZ A,(A)
PUSHJ P,NOTNOT
MOVEM A,VGCTWA
JRST GCTWX
GCTWI: SETOM IRMVF
GCTWX: MOVEI A,IN0
SKIPGE IRMVF
ADDI A,1
SKIPE VGCTWA
ADDI A,10
POPJ P,
;COPYSYMBOL CPSY CPSY0 CPSY1
SUBTTL COPYSYMBOL FUNCTION
COPYSYMBOL:
JUMPE A,CPOPJ ;IF NIL THEN DON'T COPY
JSP T,SPATOM
JSP T,PNGE
JUMPN B,CPSY0 ;IF NON-NIL SECOND ARG COPY PLIST, VC AND ARGS
CPSY: PUSHJ P,PNGT0 ;COPY THE SYMBOL
JRST SYCONS
CPSY0: PUSH P,A ;SAVE OLD SYMBOL
PUSHJ P,CPSY ;GET A NEW COPY
EXCH A,(P) ;SAVE NEW COPY, GET OLD
PUSH P,A ;SAVE OLD ON TOP OF STACK
HRRZ A,(A) ;GET PLIST
JUMPE A,CPSY1 ;IF NO PLIST THEN TRY VALUE CELL
MOVEI B,NIL ;NOW GET A NEW COPY OF THE PLIST
PUSHJ FXP,SAV5M3
PUSHJ P,.APPEND
PUSHJ FXP,RST5M3
HRRM A,@-1(P) ;STORE IN NEW SYMBOL
CPSY1: HLRZ A,@(P) ;POINTER TO OLD SYMBOL BLOCK
HLRZ T,1(A) ;ARGS PROPERTY
JUMPE T,.+3 ;IF NONE THEN DON'T HACK
HLRZ TT,@-1(P) ;ELSE COPY THE ARGS PROPERTY
HRLM T,1(TT)
HRRZ A,@(A) ;CONTENTS OF VALUE CELL
CAIN A,QUNBOUND ;IF UNBOUND DON'T BOTHER COPYING
JRST S1PAJ
EXCH AR1,-1(P) ;ELSE COPY VC BY DOING A (SET NEW OLD)
JSP T,.SET
EXCH AR1,-1(P)
JRST S1PAJ
;SETSYNTAX RSSYN1 RSSYN2 RSSYN3 RSSYN5 RSSYN7 RSSYN8 CTRUE RSSYN4
SUBTTL SETSYNTAX AND OTHER READER SYNTAX FUNCTIONS
;ARGS ARE CHAR (AS NUMBER OR ATOM), SYNTAX-CODE, MACRO-OR-TRANSLATION
SETSYNTAX: SETZ AR1, ;SUBR 3
MOVEI AR2A,(B)
JSP T,SPATOM
JRST RSSYN1
JSP T,CHNV1
JSP T,FIX1A
RSSYN1: CAIN AR2A,QMACRO
JRST RSSYN2
CAIE AR2A,QSPLICING
JRST RSSYN3
MOVEI AR1,[QSPLICING,,NIL]
RSSYN2: MOVE B,A
PUSH P,CTRUE
PUSH P,AR1
JRST SSMC43
RSSYN3: MOVSI AR1,40000 ;WAY TO FAKE OUT SSYN0
MOVEI B,(A)
JUMPE C,RSSYN5 ;SKIP IF NO CHTRAN STUFF
PUSHJ P,RSSYN4
HRRZM A,(FXP)
MOVEI A,(B) ;LOSING RETROFIT FOR NSTST
MOVEI B,(C)
PUSHJ P,SSCHTRAN
SUB FXP,R70+1
RSSYN5: JUMPE AR2A,TRUE ;XIT IF NO SYNTAX STUFF
CAIE AR2A,QSINGLE
JRST RSSYN7
NW% PUSH FXP,[600500]
NW$ PUSH FXP,[RS.SCS]
MOVEI C,(FXP)
JRST RSSYN8
RSSYN7: MOVE C,AR2A
PUSHJ P,RSSYN4
HLRZS (FXP)
RSSYN8:
MOVEI A,(B) ;LOSING RETROFIT FOR NSTAT
MOVEI B,(C)
PUSHJ P,SSSYNTAX
SUB FXP,R70+1
CTRUE: JRST TRUE
RSSYN4: PUSH FXP,R70
MOVEI A,(C)
JSP T,SPATOM
POPJ P,
MOVEI C,(B) ;SAVE B
JSP T,CHNV1
MOVEI A,(TT)
MOVEI B,(C) ;RESTORE B
MOVEI C,(FXP) ;SET C TO BE FIXNUM ON TOP OF PDL
JSP T,RSXST
MOVE TT,@RSXTB
MOVEM TT,(FXP)
POPJ P,
;SSCHTRAN SSSYNTAX SSSYN1 GRCTI SMACRO SMCR1 GETMAC
SSCHTRAN:
NW% SKIPA F,[HRRM R,(TT)]
NW$ SKIPA F,[DPB R,[001100+TT,,]]
SSSYNTAX:
NW% MOVSI F,(HRLM R,(TT))
NW$ MOVE F,[LDB R,[113300+TT,,]]
PUSH P,[SPROG3]
MOVSI AR1,40000 ;LOSING CROCK
SSSYN1:
MOVEI C,(B) ;LOSING CROCK
MOVEI B,(A)
PUSHJ P,GRCTI ;GET INDEX FOR RCT INTO D
TLNE AR1,40000 ;40000 BIT SAYS EVAL 3RD ARG
JSP T,FXNV3
JSP T,SMCR2 ;LOCK AND SETUP RCT ARRAY PTR INTO TT
ADDI TT,(D)
XCT F ;MAY SKIP (FOR (STATUS CHTRAN))
UNLKPOPJ ;MUST BE ONLY ONE INSTRUCTION.
NW% TLNE TT,4000 ;SKIP UNLESS MACRO CHAR
NW$ TLNE TT,(RS.MAC);SKIP UNLESS MACRO CHAR
MOVEI TT,(D) ;USE CHARACTER AS ITS OWN CHTRAN
TLZ TT,-1
UNLKPOPJ
GRCTI: JSP T,FXNV2 ;GET READTABLE INDEX
SA% CAIGE D,NASCII
SA$ CAIGE D,1010
JUMPGE D,CPOPJ
JRST GRCTIE
SMACRO:
MOVEI B,(A)
PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
SMCR1: MOVEI A,NIL
MOVE C,(TT)
UNLOCKI
NW% TLNN C,4000
NW$ TLNN C,(RS.MAC)
POPJ P, ;EXIT WITH NIL IF NO MACRO CHAR
NW% TLNE C,40
NW$ TRNE C,RS.ALT
MOVEI A,QSPLICING ;SPLICING TYPE
PUSHJ P,NCONS
NW% MOVEI B,(C)
NW$ PUSH P, A
NW$ PUSHJ P, GETMAC
NW$ HRRZ B, (A) ;CDR OF ASSQ IS FUNCTION
NW$ POP P, A
PUSHJ P,XCONS
POPJ P,
IFN NEWRD,[
;;;ROUTINE TO GET MACRO ENTRY. CHAR IN D.
;;; CLOBBERS A, B, TT, RETURNS (CHAR . FCN) IN A
;;; RSXST MUST HAVE BEEN DONE
GETMAC: MOVEI A, 206 ;GET FCN LIST FROM READTABLE
HRRZ B, @RSXTB ;..
MOVE A, D ;CHARACTER
PUSHJ P, IASSQF ;DEPENDS ON D,R,F BEING PRESERVED
JUMPE A, [LERR [SIXBIT/MACRO CHARACTER VANISHED#!!/]]
POPJ P,
] ;END OF IFN NEWRD
;SSMACRO SSMC43 SSM4 SSM4AA SSM3 SMCR2 SSM1
SSMACRO:
CAME T,XC-3 ;CROCK TO GET NSTAT UP FAST
PUSH P,R70
POP P,A
POP P,C
POP P,B
SKIPE A
PUSHJ P,ACONS
PUSH P,A
SSMC43: PUSHJ P,GRCTI
JSP T,SMCR2
ADD TT,D
HRRZM TT,RM4
JUMPE C,SSM1
NW% HRLI C,404500
NW$ MOVE C,[RS.CMS]
SKIPE A,(P)
JRST SSM3
SSM4:
EXCH C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCREL ;CLOBBERS C
IFN NEWRD,[
TLNN C,(RS.MAC)
JRST SSM4AA
PUSHJ P, GETMAC
;REMOVE PREVIOUS MACRO FUNCTION FROM ASSQ LIST.
;**** (SETQ MAC-LIST (DELQ A MAC-LIST)) ****
SSM4AA: ;AND NO GCREL CRUFT NECC.
]
MOVE C,@RM4
NW% HRRZ A,C
NW% TLNE C,4000
NW% PUSHJ P,SSGCPRO
NW% HRRM A,@RM4
NW$ DPB D, [001100,,@RM4] ;MACROS MUST HAVE SELF AS CHTRAN
NW$ MOVE B, D ;***SURELY THIS COULD BE A LOT LESS KLUDGEY***
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVE A, @RSXTB
NW$ PUSHJ P, XCONS
NW$ MOVE B, A
NW$ MOVEI A, 206
NW$ MOVEM B, @RSXTB
SUB P,R70+1
MOVE TT,RM4
JRST SMCR1
SSM3: MOVEI AR1,(B)
HLRZ A,(A)
JSP T,CHNV1
CAIN TT,"S ;SPLICINGP
NW% TLO C,40
NW$ TRO C,RS.ALT
MOVEI B,(AR1)
JRST SSM4
SMCR2: LOCKI
JRST RSXST
SSM1: HRLI D,2
MOVE C,RCT0(D)
NW% TLNE C,4000 ;WAS IT ORIGINALLY A MACRO CHAR?
NW$ TLNE C,(RS.MAC)
MOVE C,D
JRST SSM4
;SSGCREL SSGCPRO SSGCP1 SSPROQ SSPROX SSGRL2 SSGRL1
SSGCREL: TDZA D,D ;MUST HAVE USER INTERRUPTS OFF
SSGCPRO: MOVEI D,1
JSP T,SPATOM
JRST SSGCP1
HLRZ T,(A) ;GET SYMBOL BLOCK, FIRST WORD
MOVE T,(T)
TLNE T,SY.CCN ;IF SYM NOT PROTECTED BECAUSE OF BEING
POPJ P, ; "NEEDED" BY COMPILED CODE, THEN PROLIS-IFY
SSGCP1: SAVE A B
HRRZ R,(B)
CAIGE R,200
HRL R,VREADTABLE
HRRI R,IN0(R)
MOVE B,PROLIS
JUMPE D,SSGRL1
PUSHJ P,ASSOC
JUMPE A,SSPROQ
HLRZ A,(A)
MOVEM A,-1(P)
SSPROQ: MOVE B,R
PUSHJ P,CONS1
MOVE B,-1(P)
PUSHJ P,XCONS
MOVE B,PROLIS
PUSHJ P,CONS
MOVEM A,PROLIS
MOVE A,-1(P)
SSPROX: POP P,B
JRST POP1J
SSGRL2: MOVE A,-1(P)
SSGRL1: PUSHJ P,IASSQF ;INTERNAL ASSQ WITH NO CHECKING
JRST SSPROX ; NO SKIP ON FAILURE TO FIND
HRRZ B,(B) ; SKIP ON SUCCESS
HRRZ T,(A)
CAME R,(T) ;COMPARES READTABLE AND NUMBER
JRST SSGRL2
MOVE B,PROLIS
PUSHJ P,.DELETE
MOVEM A,PROLIS
MOVEI A,NIL
JRST SSPROX
;AUTOLOAD
AUTOLOAD:
HRL A,T
PUSHJ P,ACONS
MOVSS (A)
PUSH P,A ;FOR GC PROTECTION
PUSH FXP,D
MOVSI D,(A)
HRRI D,1000 ;AUTOLOAD USER INTERRUPT
PUSHJ P,UINT
POP FXP,D
JRST POP1J
;SYSCALL SCSL0 SCSL1 SCSL1A SCSL6 SCSL3 SCSL4 SCSL5 SCSTMA SCSFAI SCSXIT SCSXT1 SCSTAT STATER SSTATUS STATUS STAT1 STAT2 STAT3 STAT6 STAT6A STAT7 STAT8
IFN ITS,[
SUBTTL SYSCALL FUNCTION
SYSCALL:
MOVEI D,QSYSCALL
CAML T,[-10.]
CAMLE T,XC-2
JRST WNALOSE
MOVEI D,2(P)
ADD D,T ;D POINTS TO ARG WITH .CALL NAME IN IT
MOVNM T,SYSCL8 ;#ARGS+2
JSP T,0PUSH+2(T) ;PUSH SLOTS FOR COPYING FIXNUM ARGS
SCSL0: MOVE A,-1(D)
JSP T,FXNV1 ;<CONTROL-BITS>,,<NUMBER-OF-OUTPUTS-DESIRED>
HLL D,TT
HRRZS TT
CAILE TT,20
JRST SCSTMA
HRLM TT,SYSCL8 ;#ANSWERS,,#ARGS+2
MOVE A,(D)
PUSH FXP,D
PUSHJ P,SIXMAK
MOVSI D,(SETZ)
EXCH D,(FXP) ;THE SETZ GETS PUT OUT HERE
MOVEI R,-1(FXP)
MOVEI F,(FXP)
PUSH FXP,TT ;THE SIXBIT FOR THE NAME OF THE .CALL
HLRZ T,D
TLZ D,-1
TLO T,5000 ;THE CONTROL BITS ARG
JRST SCSL1A
SCSL1: HRRZ T,(D)
SKOTT T,FX
JRST SCSL1A
MOVE TT,(T)
MOVEM TT,(R)
MOVEI T,(R)
SUBI R,1
SCSL1A: PUSH FXP,T
MOVEI AR1,(T)
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
MOVEI T,(AR1) ;THIS IS AN INLINE CODED XFILEP
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,SA
JRST SCSL6
MOVE T,ASAR(AR1) ;MUST ALSO HAVE FILE BIT SET
TLNN T,AS.FIL\AS.JOB ;ALLOW EITHER JOB OR FILE
JRST SCSL6
MOVE TT,[@TTSAR]
ADDM TT,(FXP)
SCSL6:
CAIGE D,(P) ;LOOP TO INSTALL REMAINING INPUT ARGS
AOJA D,SCSL1
HLRZ D,SYSCL8
SOJL D,SCSL4
MOVEI T,1(FXP)
HRLI T,2000
SCSL3: PUSH FXP,T ;LOOP TO INSTALL ANSWER REQUESTS
ADDI T,1
SOJGE D,SCSL3
SCSL4: MOVSI T,(SETZ) ;FINAL SETZ SIGNALS END OF PARAMETERS
IORM T,(FXP) ;[THERE WILL ALWAYS BE AT LEAST ONE, I.E. THE CONTROL]
MOVEI TT,F.CHAN
.CALL (F)
JRST SCSFAI
SETZB A,B
HLRZ D,SYSCL8
SCSL5: JUMPE D,SCSXIT ;LOOP TO LISTIFY UP NUMERIC ANSWERS
POP FXP,TT
PUSHJ P,CONSFX
SOJA D,SCSL5
SCSTMA: MOVEI TT,15
JRST SCSXT1
SCSFAI: .SUSET [.RBCHN,,R]
.CALL SCSTAT
.VALUE
LDB TT,[220600,,D]
MOVE D,SYSCL8
HLRS D
SUB FXP,D ;TAKE OFF THE SLOTS FOR ANSWERS
JSP T,FXCONS ;LISP NUMBER FOR ERROR CODE
SCSXIT: MOVE D,SYSCL8 ;SYSCL8 HAS 2+#ARGS
ADDI D,-1(D) ;PUSHED WAS 3+2*#ARGS
HRLS D ; WHICH IS 2*SYSCL8-1
SUB FXP,D
SCSXT1: MOVE D,SYSCL8
HRLS D
SUB P,D ;STRAIGHTEN UP P
POPJ P,
SCSTAT: SETZ
SIXBIT \STATUS\ ;GET CHANNEL STATUS
,,R ;CHANNEL #
402000,,D ;STATUS WORD
.SEE IOCERR
.SEE CHNI1
] ;END OF IFN ITS
;;@ STATUS 194 HAIRY STATUS FUNCTIONS
;;; ***** MACLISP ****** HAIRY STATUS FUNCTIONS ******************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL INTERPRETER FOR STATUS SERIES
STATER: MOVEI B,(AR2A)
MOVEI A,(F)
PUSHJ P,CONS
FAC [ILLEGAL REQUEST!]
SSTATUS:
SKIPA F,CQSSTATUS ;FEXPR
STATUS: MOVEI F,QSTATUS ;FEXPR
MOVEI AR2A,(A)
JUMPE A,STATER
HLRZ A,(A) ;FIRST ARG IS FUNCTION NAME
PUSHJ P,STLOOK ;LOOK IT UP IN ASCII TABLE
JRST STATER
CAIE F,QSTATUS ;STATUS OR SSTATUS?
ADDI R,STBSS-STBS
ADDI R,STBS
MOVE D,(R) ;GET TABLE ENTRY
LSH D,13
ASH D,-12
TLO D,1
HRRI D,(F)
MOVEM D,SWNACK ;HACK FOR ARGS CHECKING
MOVEI A,(AR2A)
MOVEI TT,SWNACK
JRST FWNACK
;RETURN HERE FROM FWNACK IF ARGS OKAY
STAT1: HRRZ A,(A) ;CDR ARGS LIST
HRLI R,410200
PUSH FXP,R ;BYTE POINTER TO ARGS DESCRIPTORS
PUSH FXP,R70 ;COUNTER FOR ARGS
STAT2: JUMPE A,STAT6 ;JUMP IF NO MORE ARGS
PUSH P,A
HLRZ A,(A) ;ELSE GET NEXT ARG
ILDB T,-1(FXP) ;GET ARG DESCRIPTOR
JRST .+1(T)
JRST STAT6 ;0 END OF ARGS
JRST STAT3 ;1 QUOTED ARG
JRST STAT8 ;2 QUOTED LIST OF REST
PUSHJ P,EVAL ;3 EVALUATED ARG
STAT3: EXCH A,(P) ;LEAVE ARG ON PDL
HRRZ A,(A)
SOS T,(FXP) ;COUNT ARGS
CAML T,XC-4 ;NO MORE THAN FOUR ALLOWED
JRST STAT2 ; (UNLESS IT IS AN LSUBR)
MOVSI TT,020000 ;FOR AN LSUBR, ARRANGE FOR
ADDB TT,-1(FXP) ; THE LAST ARG SPEC TO BE REUSED
LDB TT,[410300,,(TT)] ;SEE WHETHER IT'S REALLY AN LSUBR
CAIE TT,1
CAIN TT,3
JRST STAT2
STAT6: POP FXP,T ;-<# OF ARGS>
POP FXP,F ;RH IS ADDRESS OF TABLE ENTRY
LDB TT,[410300,,(F)] ;GET STATUS SUBR DISPATCH TYPE
STAT6A: HRRZ D,(F)
JRST STAT7(TT)
STAT7: JSP R,PDLA2(T) ;0 SUBR-TYPE FUNCTION
JRST (D) ;1 LSUBR-TYPE FUNCTION
JRST STSCH ;2 SUBR-TYPE WITH CHAR ARG
JRST STSCH ;3 LSUBR-TYPE WITH CHAR ARG
JRST STSGVAL ;4 GET LISP VALUE
JRST STSSVAL ;5 SET LISP VALUE
JRST STSSTNIL ;6 SET TO T-OR-NIL
MOVE TT,(D) ;7 GET FIXNUM VALUE
JRST FIX1
STAT8: MOVE A,(P)
SETZM (P)
JRST STAT3
;STSGVAL CQSSTATUS STSSVAL STSSV1 STSSTNIL STLOOK STLK1 STSCH STSCH1 STSCH2
STSGVAL: HRRZ A,(D)
CQSSTATUS: POPJ P,QSSTATUS
STSSVAL: POP P,A
JSP T,PDLNMK
STSSV1: MOVEM A,(D)
POPJ P,
STSSTNIL: POP P,A
PUSHJ P,NOTNOT
JRST STSSV1
STLOOK: PUSHJ P,PNGET ;LOOK UP 5 CHARS IN TABLE
HLRZ A,(A) ;F SAYS WHETHER STATUS OR SSTATUS
MOVE TT,(A) ;SKIP ON SUCCESS, LEAVING POINTER IN R
MOVSI R,-LSTBA
CAIE F,QSTATUS
MOVSI R,-LSSTBA
STLK1: CAMN TT,STBA(R)
JRST POPJ1
AOBJN R,STLK1
POPJ P,
STSCH: PUSH FXP,F
PUSH FXP,T
ADDI T,1(P)
HRRZ A,(T)
JSP T,SPATOM
JRST STSCH1
PUSHJ P,PNGET
HLRZ A,(A)
MOVE TT,(A)
LSH TT,-35
JSP T,FXCONS
JRST STSCH2
STSCH1: PUSHJ P,EVAL
JSP T,FXNV1
STSCH2: MOVE T,(FXP)
ADDI T,1(P)
HRRM A,(T)
POP FXP,T
POP FXP,F
LDB TT,[410300,,(F)]
SUBI TT,2
JRST STAT6A
;SNOFEATURE SFEATURE SSFEATURE SSFEA1 SSFEA2 SSNOFEATURE SSSSLU SSSSS SSSS SSSSS1 SARRAY
SUBTTL STATUS FEATURES FEATURE NOFEATURE, SSTATUS, ARRAY
SNOFEATURE:
PUSH P,CNOT
SFEATURE:
HRRZ B,FEATURES
JUMPE A,BRETJ
HLRZ A,(A)
PUSHJ P,MEMQ1
JRST NOTNOT
SSFEATURE:
PUSH P,A
HRRZ B,FEATURES
PUSHJ P,MEMQ1
JUMPN A,SSFEA2
HRRZ A,(P)
HRRZ B,FEATURES
PUSHJ P,CONS
SSFEA1: MOVEM A,FEATURES
SSFEA2: JRST POPAJ
SSNOFEATURE:
PUSH P,A
HRRZ B,FEATURES
PUSHJ P,.DELQ
JRST SSFEA1
SSSSLU: POP P,A
PUSHJ P,STLOOK
JRST FALSE
JRST TRUE
SSSSS: SKIPA F,CQSSTATUS
SSSS: MOVEI F,QSTATUS
JUMPN T,SSSSLU
PUSH P,R70
CAIN F,QSTATUS
SKIPA F,[-LSTBA,,]
MOVSI F,-LSSTBA
SSSSS1: MOVE T,STBA(F)
MOVEM T,PNBUF
SETOM LPNF
MOVEI C,PNBUF
PUSHJ P,RINTERN
MOVE B,(P)
PUSHJ P,CONS
MOVEM B,(P)
AOBJN F,SSSSS1
JRST POPAJ
;STATUS ARRAY RETURNS A LIST OF FOUR NUMBERS:
; <MIN # OF DIMS> <MAX # OF DIMS> <MIN AXIS LENGTH> <MAX AXIS LENGTH>
;THE LIST IS FRESHLY CONSED ON EACH CALL, AND MAY BE DESTRUCTIVLY MODIFIED
SARRAY: SETZ B, ;START WITH NIL
MOVEI TT,777777 ;APPROXIMATION OF MAXIMUM AXIS LENGTH
JSP T,FXCONS
JSP T,%CONS
MOVEI B,IN1
JSP T,%XCONS
MOVEI B,IN5
JSP T,%XCONS
MOVEI B,IN1
JRST XCONS ;CONS UP FINAL NUMBER THEN RETURN
;SSPLSS SPLSS SCHTRAN SSYNTAX
SUBTTL STATUS +, STATUS CHTRAN, STATUS SYNTAX
SSPLSS: MOVEI C,RD8N
SKIPE A
MOVEI C,RD8W
MOVEM C,RDOBJ8
SPLSS: MOVE A,RDOBJ8
SUBI A,RD8N
JRST NOTNOT
SCHTRAN:
SKIPA F,[SKIPA TT,(TT)]
SSYNTAX:
NW% MOVSI F,(HLRZ TT,(TT))
NW$ MOVE F,[LDB TT,[113300+TT,,0]]
PUSH P,CFIX1
SETZ AR1, ;CROCK
JRST SSSYN1
;STTY STTY1 ZZZ STTY3 STTY4 ZZZ ZZZ
SUBTTL STATUS TTY, SSTATUS TTY
;;; (STATUS TTY <FILE>) RETURNS A LIST OF NUMBERS CONCERNING THE TTY:
;;; FOR ITS: (<TTYST1> <TTYST2> <TTYSTS>)
;;; FOR D10: (<GETLCH WORD> <FILE STATUS>)
;;; FOR SAIL: (<GETLIN WORD> <FILE STATUS> <SETACT 1> <SETACT 2> <SETACT 3> <SETACT 4>)
;;; FOR D20: (<CCOC 1> <CCOC 2> <JFN MODE WORD> <DEFERRED INTERRUPT CHARS MASK>)
;;; RETURNS NIL IF <FILE> IS OMITTED AND THE JOB DOES NOT POSSESS A CONTROLLING TTY.
STTY: JUMPN T,STTY1
;TEST TO SEE WHETHER WE POSSESS A CONTROLLING TTY
IFN ITS,[
.SUSET [.RTTY,,TT] ;FOR ITS, SEE IF THIS JOB HAS THE TTY
JUMPL TT,FALSE .SEE %TBNOT
] ;END OF IFN ITS
IFN D10,[
IFN SAIL,[
GETLN D, ;RETURNS ZERO IF JOB IS DETACHED
JUMPN D,FALSE
] ;END OF IFN SAIL
IFE SAIL,[
GETLIN D, ;FOR D10, LH OF GETLIN WORD ZERO
TLNN D,-1 ; MEANS JOB IS DETACHED
JRST FALSE
] ;END OF IFE SAIL
] ;END OF IFN D10
IFN D20,[
LOCKI
GJINF ;FOURTH RETURNED VALUE IS -1 FOR
MOVE T,4
SETZB 1,2 ; A DETACHED JOB
SETZB 3,4
UNLOCKI
AOJE T,FALSE
] ;END OF IFN D20
SKIPA AR1,V%TYI
STTY1: POP P,AR1
PUSHJ P,TFILOK ;SAVES D (FOR SAIL), DOES A LOCKI
POP FXP,T ;POP THE LOCKI WORD
IFN ITS,[
.CALL TTYGET ;GET THREE VALUES IN D, R, F
.LOSE 1400
PUSH FXP,D ;TTYST1
PUSH FXP,R ;TTYST2
PUSH FXP,F ;TTYSTS
ZZZ==3
] ;END OF IFN ITS
IFN D10,[
PUSHJ P,D10TNM ;RETURNS APPROPRIATE TERMINAL NUMBER IN D
SA% GETLCH D
SA$ GETLIN D
PUSH FXP,D
SKIPL F.MODE(TT) .SEE FBT.CM
JRST STTY3
MOVSI R,(SIXBIT \TTY\) ;FOR THE REGULAR TTY,
SETZB D,F ; OPEN A TEMPORARY CHANNEL
OPEN TMPC,D ; SO CAN GET THE CHANNEL STATUS
HALT
GETSTS TMPC,D
RELEASE TMPC,
JRST STTY4
STTY3: MOVE R,F.CHAN(TT) ;FOR ANY OTHER TTY, USE THE EXISTING CHANNEL
LSH R,27
IOR R,[GETSTS 0,D]
XCT R
STTY4: PUSH FXP,D
IFE SAIL, ZZZ==2
IFN SAIL,[
PUSHN FXP,4
MOVSI D,-3(FXP)
SETACT D ;GET FOUR ACTIVATION WORDS
ZZZ==6
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT)
RFCOC ;READ CCOC WORDS
PUSH FXP,2 ;CCOC1
PUSH FXP,3 ;CCOC2
RFMOD ;READ JFN MODE WORD FOR TERMINAL
PUSH FXP,2
MOVE 1,[RT%DIM,,.FHSLF]
RTIW ;READ DEFERRED INTERRUPT WORD
PUSH FXP,3
SETZB B,C
ZZZ==4
] ;END OF IFN D20
PUSH FXP,T ;LOCKI WORD
UNLOCKI
PUSHJ P,CONS1PFX
REPEAT ZZZ-2, PUSHJ P,CONSPFX
JRST CONSPFX
EXPUNGE ZZZ
;SSTTY SSTTY1 SSTTY3 SSTTY7 SSTTY3 SSTTY4 SSTTY5 SSTTY3 SSTTY4 SSTTY2 TTY2ST TTYSAC
;;; (SSTATUS TTY <NUM1> <NUM2> ... <NUMN> <TTY>) SETS THE
;;; TTY STATUS WORDS FOR <TTY> (WHICH MAY BE OMITTED).
;;; ANY PARAMETERS WHICH ARE OMITTED OR NIL ARE NOT CHANGED.
SSTTY: HRRZ AR1,(P) ;LSUBR
CAIN AR1,TRUTH ;LAST ARG T => DEFAULT TTY
HRRZ AR1,V%TYI
JSP TT,XFILEP ;SEE IF LAST ARG IS A TTY
SKIPA AR1,V%TYI ;IF NOT, WE USE THE DEFAULT
AOSA D,T ;IN ANY CASE, PUT ADJUSTED NUMBER
SKIPA D,T ; OR ARGUMENTS IN D
POPI P,1 ; AND ADJUST THE STACK
SKIPN F,D ;NO ARGUMENTS MEANS CHANGE NOTHING
JRST TRUE
MOVE R,FXP ;SAVE CURRENT LEVEL OF FXP
SSTTY1: POP P,A ;FOR EACH ARGUMENT
SKIPE A ; WE PUSH TWO
JSP T,FXNV1 ; WORDS ONTO FXP:
PUSH FXP,TT ; THE FIRST IS THE NUMERIC VALUE, IF ANY,
PUSH FXP,A ; AND THE SECOND IS ZERO IF THE ARG WAS NIL
AOJL D,SSTTY1
;BECAUSE THE ARGUMENTS WERE POPPED OFF P IN REVERSE ORDER,
; THEY CAN NOW BE POPPED OFF FXP IN THE CORRECT ORDER.
;F HAS THE NEGATIVE OF THE NUMBER OF ARGUMENTS.
PUSH P,R ;NOW SAVE OLD FXP ON STACK
PUSHJ P,TIFLOK ;DOES A LOCKI, SAVES F
POP FXP,AR2A ;POP LOCKI WORD
IFN ITS,[
POP FXP,T
POP FXP,D
SKIPN T
SKIPA D,TI.ST1(TT) ;GET COPY OF THE OLD VALUE IF NOT SETTING NEW
MOVEM D,TI.ST1(TT) ;UPDATE TTYST1 WORD
AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS
POP FXP,T
POP FXP,R
SKIPN T
SKIPA R,TI.ST2(TT)
MOVEM R,TI.ST2(TT) ;UPDATE TTYST2 WORD
AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS
POP FXP,T
POP FXP,F
JUMPE T,SSTTY3 ;NULL THIRD ARG, THEN NEEDN'T DO HAIRIER CALL
.CALL TTYSAC ;THREE WORDS ARE IN D, R, F
.LOSE 1400
JRST SSTTY2
SSTTY3: .CALL TTY2ST ;SET JUST TTYST1, TTYST2
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
POP FXP,D
POP FXP,T
JUMPE D,SSTTY7
IFE SAIL,[
PUSHJ P,D10TNM
CAMN D,XC-1
GETLCH D
HRRI T,(D)
SETLCH T
] ;END OF IFE SAIL
IFN SAIL,[
SKIPL F.MODE(TT) .SEE FBT.CM
SETLIN T
] ;END OF IFN SAIL
SSTTY7: AOJE F,SSTTY2
POP FXP,D
POP FXP,T
JUMPE D,SSTTY4 ;FOR NULL ARG, FORGET THE FOLLOWING HAIR
SKIPL F.MODE(TT) .SEE FBT.CM
JRST SSTTY3
PUSH FXP,F
MOVSI R,(SIXBIT \TTY\)
SETZB D,F
OPEN TMPC,D ;OPEN A TEMP CHANNEL FOR THE TTY
HALT
SETSTS TMPC,T ;SET THE STATUS
RELEASE TMPC,
POP FXP,F
JRST SSTTY4
SSTTY3: MOVE R,F.CHAN(TT)
LSH R,27
IOR R,[SETSTS 0,T]
XCT R
SSTTY4:
IFN SAIL,[
AOJE F,SSTTY2 ;JUMP IF NO MORE ARGS
IRPC X,,[1234]
POP FXP,D
POP FXP,T
SKIPE D
MOVEM T,TI.ST!X(TT) ;UPDATE ACTIVATION WORD X
IFSN X,4, AOJE F,SSTTY5
TERMIN
SSTTY5: MOVEI T,TI.ST1(TT)
SETACT T
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT) ;GET JFN FOR SUBSEQUENT JSYS'S
POP FXP,T
POP FXP,D
SKIPE T
MOVEM D,TI.ST1(TT) ;UPDATE CCOC1
AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS
POP FXP,T
POP FXP,R
SKIPE T
MOVEM R,TI.ST2(TT) ;UPDATE CCOC2
IOR D,R
SSTTY3: JUMPE D,SSTTY4 ;JUMP IF NO CHANGE TO CCOC'S
MOVE 2,TI.ST1(TT)
MOVE 3,TI.ST2(TT)
SFCOC ;SET CCOC'S
SSTTY4: AOJGE F,SSTTY2 ;JUMP IF NO MORE ARGUMENTS
POP FXP,D
POP FXP,2
SKIPE D
SFMOD ;UPDATE JFN MODE WORD
AOJE F,SSTTY2
POP FXP,D
POP FXP,3 ;DEFERRED TERMINAL INTERRUPT MASK
JUMPE D,SSTTY2
MOVE 1,[ST%DIM,,.FHSLF]
MOVE 2,[STDTIW] ;STANDARD TERMINAL INTERRUPT WORD
STIW ;SET TERMINAL INTERRUPT WORDS
] ;END OF IFN D20
SSTTY2: POP P,FXP ;RESTORE FXP
PUSH FXP,AR2A ;PUSH BACK LOCKI WORD
20$ SETZB B,C ;CLEAR JUNK OUT OF AC'S
JRST UNLKTRUE
IFN ITS,[
TTY2ST: SETZ
SIXBIT \TTYSET\ ;SET TTY VARIABLES
,,F.CHAN(TT) ;CHANNEL #
,,TI.ST1(TT) ;TTYST1
400000,,TI.ST2(TT) ;TTYST2
TTYSAC: SETZ
SIXBIT \TTYSET\ ;SET TTY VARIABLES
,,F.CHAN(TT) ;CHANNEL #
,,D ;TTYST1
,,R ;TTYST2
400000,,F ;TTYSTS
] ;END OF IFN ITS
;SFRET
SFRET: CAIN B,QBPS ;FIGURE OUT SPACE TYPE
JRST 1(R) ;BPS => SKIP 1
CAIN B,QRANDOM ;BAD SPACE TYPE => SKIP 0
JRST (R) ;LIST, FIXNUM, FLONUM, BIGNUM,
CAIN B,QARRAY ; SYMBOL, SAR => SKIP 2
MOVEI B,QRANDOM
CAIL B,QLIST
CAILE B,QRANDOM
JRST (R)
2DIF [HRREI TT,(B)]-NFF,QLIST
JRST 2(R)
;SUUOLINKS SUUOL1 SSUUOLINKS SSUUL1 SCLI SSCLI CLIVAR
SUBTTL STATUS UUOLI, SSTATUS UUOLI, STATUS IOC, STATUS CLI, SSTATUS CLI
SUUOLINKS:
IFE PAGING,[
SKIPN T,LDXSIZ
JRST FALSE ;RETURN NIL IF NO XCT HACKERY HAS BEEN DONE
SETZB TT,D ;ZERO COUNTER
TLNE T,400000
MOVEI D,TRUTH ;D GETS TRUE IF PURIFIED
MOVNS T ;MAKE UP AOBJN POINTER FOR XCT CALL AREA 2
HLL T,LDXBLT
MOVSS T
SUUOL1: SKIPN (T) ;COUNT FREE CELLS IN XCT CALL AREA
AOS TT
AOBJN T,SUUOL1
JSP T,FIX1A ;RETURN LIST OF PURE FLAG AND COUNT
PUSHJ P,NCONS
MOVE B,D
JRST XCONS
] ;END IFE PAGING
IFN PAGING,[
SKIPN LDXPNT ;IF NO XCT PAGES
JRST FALSE ; RETURN FALSE
MOVN TT,LDXLPC ;GET NUMBER OF FREE SLOTS IN LAST SEGMENT
JSP T,FIX1A
PUSHJ P,NCONS
MOVEI B,NIL
SKIPE LDXPFG ;PURIFIED?
MOVEI B,TRUTH
JRST XCONS
] ;END IFN PAGING
SSUUOLINKS:
IFE PAGING,[
SKIPN TT,LDXBLT ;ZAP CALLS FOR XCTS WITH A BLT
JRST FALSE
MOVEI T,(TT)
ADD T,LDXSM1
BLT TT,(T)
JRST TRUE
] ;END IFE PAGING
IFN PAGING,[
SKIPN T,LDXPNT ;LOOP OVER ALL XCT SEGMENTS
JRST FALSE
SSUUL1: JUMPE T,TRUE ;RETURN TRUE WHEN DONE
HRRZI TT,LDXOFS(T) ;TARGET ADR
HRL TT,LDXPSP(T) ;ADR-OFFSET TO GET DATA FROM
ADD TT,[LDXOFS,,0] ;MAKE INTO SOURCE ADR
BLT TT,SEGSIZ-1(T) ;RECOPY LINK AREA
HLRZ T,LDXPSP(T) ;LINK TO NEXT PAGE
JRST SSUUL1
] ;END IFN PAGING
IFN USELESS*ITS,[
SCLI: MOVEI T,%PICLI ;TEST TO SEE IF THIS BIT IS ON (IN IMASK)
TDNN T,IMASK ;IF ON, RETURN T, ELSE RETURN NIL
JRST FALSE
JRST TRUE
SSCLI: MOVEI T,%PICLI
MOVEI TT,IMASK
SKIPN A ;ON OR OFF?
TLOA TT,(ANDCAM T,) ;OFF, USE ANDCAM
HRLI TT,(IORM T,) ;ON, USE IORM
XCT TT ;MODIFY LISP'S MASK
SKIPN A
TLOA T,(TRZ)
TLO T,(TRO)
.CALL CLIVAR
.LOSE 1400 ;BAD NEWS....
JUMPN A,TRUE
POPJ P,
CLIVAR: SETZ
SIXBIT \USRVAR\
MOVEI %JSELF
MOVEI .RMASK
MOVEI
SETZ T
] ;END IFN USELESS*ITS
;STIME SDATE STCVT SUNAME SUSERID SJNAME SSUBSYSTEM SJNUMBER SHOMEDIR SHSNAME SHSNA1 SHSNA2
SUBTTL STATUS TIME, DATE, UNAME, USERID, JNAME, JNUMBER, SUBSYSTEM
IFN ITS,[
STIME: .RTIME TT,
JRST SDATE+1
SDATE: .RDATE TT,
AOJE TT,FALSE
MOVE D,TT
SUB D,[202020202021] ;21 ADJUSTS FOR THE AOJE
JSP F,STCVT
JSP F,STCVT
JSP F,STCVT
MOVNI T,3
JRST LIST
STCVT: SETZB TT,R
LSHC TT,6
IMULI TT,10.
ROTC D,6
ADD TT,R
JSP T,FXCONS
PUSH P,A
JRST (F)
SUNAME: .SUSET [.RUNAME,,TT]
JRST SIXATM
SUSERID:
.SUSET [.RXUNAME,,TT]
JRST SIXATM
SJNAME: .SUSET [.RJNAME,,TT]
JRST SIXATM
SSUBSYSTEM:
.SUSET [.RXJNAME,,TT]
JRST SIXATM
SJNUMBER:
.SUSET [.RUIND,,TT]
JRST FIX1
SHOMEDIR:
.SUSET [.RHSNAME,,TT]
JRST SIXATM
SHSNAME: ;NEW HAIRY READ HSNAME
JUMPE T,SHOMEDIR ;NO ARGS, SAME AS (STATUS HOMEDIR)
PUSH FXP,T ;SAVE NUMBER OF ARGS OVER SUPERIOR CHECK
JSP T,SIDDTP ;IS THERE A DDT ABOVE US?
JRST SHSNA2 ;NOPE...
POP FXP,T
SETZ TT, ;ASSUME NULL ITS NAME
AOJE T,SHSNA1 ;ITS ARG GIVEN?
POP P,A ;YES, GET THE ITS NAME
PUSHJ P,SIXMAK ;GET SIXBIT INTO TT
SHSNA1: PUSH FXP,TT ;SAVE THE ITS NAME
POP P,A
PUSHJ P,SIXMAK ;CONVERT UNAME TO SIXBIT
PUSH FXP,TT ;STORE THAT ON FXP ALSO
MOVEI TT,-1(FXP) ;POINTER TO FIRST WORD
HRLI TT,..RHSNAME ;FOR .BREAK 12,
.BREAK 12,TT ;READ THE HSNAME FROM DDT
POP FXP,TT ;NOW CONVERT TO AN ATOM
PUSHJ P,SIXATM
POPI FXP,1 ;REMOVE EXTRA WORD FROM STACK
POPJ P, ;THEN RETURN
SHSNA2: POP FXP,T ;RESTORE NUMBER OF ARGS
MOVNS T
SUB P,R70(T) ;REMOVE THE APPROPRIATE NUMBER OF WORDS FROM P
SETZ A, ;RETURN NIL
POPJ P,
] ;END OF IFN ITS
;SHSNAME SDATE STIME STIM2 SSUBSYSTEM SDATE STIME STIM2 SSUBSYSTEM SJNAME SJNUMBER SUSERID SUSER1 SUNAME
IFE ITS,[
SHSNAME: ;HSNAME IS SIMPLY HOMEDIR
MOVNS T
SUB P,R70(T) ;REMOVE THE APPROPRIATE NUMBER OF WORDS FROM P
MOVE A,SUDIR
POPJ P,
] ;END IFE ITS
IFN D10,[
IFE SAIL,[
SDATE: MOVE R,[%CNYER]
MOVE D,[%CNMON]
MOVE TT,[%CNDAY]
GETTAB R,
JRST FALSE
SUBI R,1900.
JRST STIM2
STIME: MOVE R,[%CNHOR]
MOVE D,[%CNMIN]
MOVE TT,[%CNSEC]
GETTAB R,
JRST FALSE
STIM2: GETTAB D,
JRST FALSE
GETTAB TT,
JRST FALSE
PUSHJ P,CONS1FX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
JRST CONSFX
SSUBSYSTEM:
HRROI TT,.GTPRG ;GET PROGRAM NAME FOR MYSELF
GETTAB TT,
JRST FALSE
JRST SIXATM
] ;END OF IFE SAIL
IFN SAIL,[
SDATE: DATE D, ;DATE IN D = <<YEAR-1964.>*12.+MONTH-1>*31.+DAY-1
IDIVI D,31. ;REMAINDER IN R IS DAYS-1
AOJ R,
MOVE T,R
IDIVI D,12. ;REMAINDER HERE IS MONTH-1
AOJ R,
ADDI D,64. ;QUOTIENT IN D IS YEAR-1964.
PUSH FXP,D
PUSH FXP,R
PUSH FXP,T
JRST STIM2
STIME: TIMER TT, ;GET TIME IN TT
IDIVI TT,60. ;REDUCE TO SECONDS
IDIVI TT,60. ;NOW GET SECONDS AS A REMAINDER
MOVE R,D
IDIVI TT,60. ;REMAINDER IS MINUTES
PUSH FXP,TT
PUSH FXP,D ;REST IS HOURS
PUSH FXP,R
STIM2: PUSHJ P,CONS1PFX ;START A LIST WITH NUMBER ON FXP
PUSHJ P,CONSPFX ;ADD FIXNUM TO LIST
JRST CONSPFX ;ADD THIRD FIXNUM TO LIST
SSUBSYSTEM:
SETO TT,
GETNAM TT, ;GET (GENERIC?) NAME OF JOB
JRST SIXATM
] ;END OF IFN SAIL
SJNAME: MOVE TT,D10NAM
JRST SIXATM
SJNUMBER: PJOB TT, ;GET JOB NUMBER
JRST FIX1
SUSERID:
IFE SAIL,[
HRROI TT,.GTNM1 ;GET USER NAME FOR THIS JOB
GETTAB TT,
JRST SUNAME
HRROI D,.GTNM2
GETTAB D,
HALT ;HOW CAN THIS LOSE?
JUMPE TT,SUNAME
SETOM LPNF ;CONVERT TWO WORDS OF SIXBIT
MOVE C,PNBP ; TO ASCII IN PNBUF
SUSER1: LDB T,[360600,,TT]
ADDI T,40
IDPB T,C
LSHC TT,6
JUMPN TT,SUSER1
PUSHJ FXP,RDAEND
JRST RINTERN ;MAKE IT AN ATOMIC SYMBOL
] ;END OF IFE SAIL
SUNAME: GETPPN TT, ;PPNATM EXPECTS PPN IN TT
JFCL
JRST PPNATM
] ;END OF IFN D10
;STIME STIME1 SDATE SDATIM SJNAME SSUBSYSTEM SUSERID SUNAME SJNUMBER
IFN D20,[
STIME: PUSHJ P,SDATIM ;RETURNS TIME IN F
MOVEI TT,(F)
IDIVI TT,60. ;REMAINDER IS SECONDS
MOVE R,D
IDIVI TT,60. ;THIS YIELDS HOURS AND MINUTES
EXCH TT,R
STIME1: PUSHJ P,CONS1FX ;CONS R, D, TT INTO A LIST OF FIXNUMS
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
JRST CONSFX
SDATE: PUSHJ P,SDATIM ;RETURNS DATE IN D AND R
HLRZ TT,R ;DAY-1
HLRZ R,D ;YEAR
SUBI R,1900. ;REDUCE IT TO A YEAR MOD 100.
MOVEI D,1(D) ;MONTH
AOJA TT,STIME1 ;INCREMENT DAY-1 TO DAY, AND GO CONS
SDATIM: LOCKI ;PREVENT JUNK IN AC'S FROM CAUSING TROUBLE
SETO 2, ;CURRENT TIME
SETZ 4,
ODCNV ;GET TIME AND DATE INFORMATION
MOVE D,2 ;RETURN INFORMATION IN D, R, F
MOVE R,3
MOVE F,4
SETZB 1,2 ;PREVENT TROUBLE AFTER UNLOCKI
SETZB 3,4
UNLKPOPJ
SJNAME: ;?
SSUBSYSTEM:
LOCKI
GETNM ;GET PROGRAM NAME
MOVE TT,1
SETZ 1,
UNLOCKI
JRST SIXATM
SUSERID: ;?
SUNAME: LOCKI
MOVE TT,[PNBUF,,PNBUF+1]
SETZM PNBUF ;CLEAR PNBUF
BLT TT,PNBUF+LPNBUF-1
GJINF ;GET JOB INFORMATION
MOVE 2,1 ;1 HAS LOGIN DIRECTORY NUMBER
MOVE 1,PNBP
DIRST ;GET EQUIVALENT ASCII STRING
HALT ;BETTER NOT FAIL...
SETZB 1,2
UNLOCKI
JRST PNBFAT ;MAKE ASCII STRING AN ATOM
SJNUMBER:
LOCKI
GJINF ;GET JOB INFORMATION
MOVE TT,3 ;JOB NUMBER
SETZB 1,2
UNLOCKI
JRST FIX1
] ;END OF IFN D20
;SSLINMODE ZZX
SUBTTL STATUS LINMODE
SSLINMODE:
CAMN T,XC-1
SKIPA AR1,V%TYI
POP P,AR1
POP P,A
PUSHJ P,TIFLOK ;DOES A LOCKI
MOVE T,F.MODE(TT)
SKIPN A
IFN ITS,[
ZZX==<%TG<ACT>>*010101010101 ;6 %TGACT BITS
SKIPA R,[STTYW1&ZZX] ;PUT APPROPRIATE ACTIVATION
SKIPA R,[STTYL1&ZZX] ; BITS IN R AND F
SKIPA F,[STTYW2&ZZX]
SKIPA F,[STTYL2&ZZX]
] ;END OF IFN ITS
IFN SAIL,[
SKIPA D,[[SACTW1 ? SACTW2 ? SACTW3 ? SACTW4],,]
SKIPA D,[[SACTL1 ? SACTL2 ? SACTL3 ? SACTL4],,]
] ;END OF IFN SAIL
IFN D20,[
SKIPA R,[XACTW]
SKIPA R,[XACTL]
] ;END OF IFN D20
TLZA T,FBT.LN
TLO T,FBT.LN
MOVEM T,F.MODE(TT)
IFN ITS,[
MOVE D,[ZZX]
ANDCAM D,TI.ST1(TT)
IORM R,TI.ST1(TT) ;CLOBBER IN ONLY ACTIVATION BITS
ANDCAM D,TI.ST2(TT)
IORM F,TI.ST2(TT)
EXPUNGE ZZX
] ;END OF IFN ITS
IFN SAIL,[
HRRI D,TI.ST1(TT)
BLT D,TI.ST4(TT) ;UPDATE STATUS WORDS
MOVEI T,TI.ST1(TT)
SETACT T ;TELL THE SYSTEM ABOUT IT
] ;END OF IFN SAIL
IFN D20,[
MOVEI D,770000 ;BITS 18.-23. ARE FOR WAKE-UP CONTROL
ANDCAM D,TI.ST3(TT)
IORM R,TI.ST3(TT)
] ;END OF IFN D20
UNLOCKI
JRST NOTNOT
;SDOW SDOWQX SDOW SDOWQX SDOW SDOWQX
SUBTTL STATUS DOW
IFN USELESS,[
IFN ITS,[
SDOW: .RYEAR TT,
AOJE TT,FALSE
LSH TT,-31
ANDI TT,16
MOVE T,SDOWQX(TT)
MOVEM T,PNBUF
MOVE T,SDOWQX+1(TT)
MOVEM T,PNBUF+1
JRST PNBFAT
SDOWQX:
IRP DAY,,[SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY]
ASCII \DAY\
TERMIN
] ;END OF IFN ITS
IFN D10,[
SDOW:
IFE SAIL,[
MOVE T,[%CNDTM] ;INTERNAL FORMAT DATE,,TIME
GETTAB T,
JRST FALSE
HLRZS T
] ;END OF IFE SAIL
IFN SAIL,[
DATE T, ;DATE IN T
DAYCNT T, ;CONVERT TO NUMBER OF DAYS
] ;END OF IFN SAIL
;T NOW HAS NUMBER OF DAYS SINCE 1-JAN-64 (A WEDNESDAY)
IDIVI T,7
LSH TT,1
MOVE T,SDOWQX(TT)
MOVEM T,PNBUF
MOVE T,SDOWQX+1(TT)
MOVEM T,PNBUF+1
JRST PNBFAT
SDOWQX: ;FUNNY ORDER FOR DEC-10
IRP DAY,,[WEDNESDAY,THURSDAY,FRIDAY,SATURDAY,SUNDAY,MONDAY,TUESDAY]
ASCII \DAY\
TERMIN
] ;END OF IFN D10
IFN D20,[
SDOW: PUSHJ P,SDATIM ;RH OF R GETS DAY OF WEEK (0 = MONDAY)
LSH R,1
MOVE T,SDOWQX(R)
MOVEM T,PNBUF
MOVE T,SDOWQX+1(R)
MOVEM T,PNBUF+1
JRST PNBFAT
SDOWQX: ;FUNNY ORDER FOR DEC-10
IRP DAY,,[MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY,SUNDAY]
ASCII \DAY\
TERMIN
] ;END OF IFN D20
] ;END OF IFN USELESS
;SABBREVIATE SSABBREVIATE SSABB1 SMEMFREE
SUBTTL STATUS ABBREVIATE, STATUS MEMFREE
IFN USELESS,[
SABBREVIATE:
MOVEI TT,LRCT-2
HRRZ A,VREADTABLE
HRRZ TT,@TTSAR(A)
JRST FIX1
SSABBREVIATE:
SKIPN TT,A
JRST SSABB1
MOVEI TT,3
CAIE A,TRUTH
JSP T,FXNV1
SSABB1: MOVEI T,(TT)
MOVEI TT,LRCT-2
HRRZ B,VREADTABLE
HRRM T,@TTSAR(B)
JRST PDLNKJ
] ;END OF IFN USELESS
SMEMFREE:
PG$ MOVE TT,HINXM ;NUMBER OF WORDS IN HOLE
PG$ SUB TT,BPSH ;INTERRUPT HERE WOULD SCREW,
PG% MOVE TT,MAXNXM
PG% SUB TT,HIXM
JRST FIX1 ; WORRY, WORRY, WHO CARES
;SSYST0 SSYSTEM SSYST7 SSYST1 SSYST3 SSYST5 SSYST4 SSYST6
SUBTTL STATUS SYSTEM
SSYST0: WTA [SYMBOL REQUIRED - STATUS SYSTEM!]
SSYSTEM: ;(STATUS SYSTEM) ENTRY-POINT
JSP T,SPATOM
JRST SSYST0
JUMPE A,SSYST6
CAIN A,TRUTH
JRST SSYST6
MOVEI AR1,NIL
MOVEI B,QSYMBOL ;CHECK FOR SYMBOL HEADER IN SYSTEM SPACE
CAIL A,SYMSYF
CAILE A,SYMSYL
JRST SSYST7 ;NOT IN RANGE, CONTINUE CHECKING
EXCH A,AR1
PUSHJ P,XCONS
EXCH A,AR1
SSYST7: MOVEI B,QVALUE
HLRZ C,(A)
HRRZ C,(C)
CAIGE C,ESYSVC
JRST SSYST4
SSYST1: MOVEI B,SSSBRL
PUSHJ P,GETLA
JUMPE A,AR1RETJ
HLRZ B,(A)
HRRZ A,(A)
HLRZ C,(A)
CAIE B,QAUTOLOAD
JRST SSYST3
CAIL C,BSYSAP ;IS IT A SYSTEM AUTOLOAD PROP?
CAIL C,ESYSAP
JRST SSYST1 ;NOPE
JRST SSYST4 ;YUP
SSYST3: CAIE B,QARRAY
JRST SSYST5
CAIL C,BSYSAR ;IS IT A SYSTEM ARRAY
CAIL C,ESYSAR
JRST SSYST1
JRST SSYST4
SSYST5: CAIL C,ENDFUN ;SUBR OR VC ADDRESS IN SYSTEM AREA
JRST SSYST1
SSYST4: EXCH A,AR1 ;A WIN, SO CONS UP THIS PROPERTY NAME
PUSHJ P,XCONS
EXCH A,AR1
JRST SSYST1
SSYST6: MOVEI A,QVALUE
PUSHJ P,NCONS
MOVEI B,QSYMBOL
JRST XCONS
;SSGCTIM SGCTIM SGCTM1 SLVRNO STTYREAD SLAP SLAP1 SSTTYREAD SSLAP SSLAP1
SUBTTL STATUS GCTIME, LISPVERSION, TTYREAD, ←, TERPRI
SSGCTIM:
JSP T,FXNV1
IT$ LSH TT,-2
10$ IDIVI TT,1000.
20$ IDIVI TT,1000.
EXCH TT,GCTIM
JRST SGCTM1
SGCTIM: MOVE TT,GCTIM
SGCTM1: PUSH P,CFIX1 ;FAKE OUT ENTRY INTO RUNTIME
JRST RNTM1
SLVRNO: MOVE A,[440600,,[LVRNO]]
JRST READ6C
STTYREAD: SKIPA TT,[LRCT-2]
SLAP: HRROI TT,LRCT-1
SLAP1: HRRZ A,VREADTABLE
MOVE A,@TTSAR(A)
SKIPL TT
MOVSS A
JRST RHAPJ
SSTTYREAD: SKIPA R,[LRCT-2]
SSLAP: HRROI R,LRCT-1
SSLAP1: PUSHJ P,NOTNOT
HRRZ D,VREADTABLE ;INTERRUPT COULD SCREW HERE (FOO)
JSP T,.STOR0
POPJ P,
;SLINMODE STERPRI STERP1 SSTERPRI
SLINMODE: MOVSI F,FBT<LN>
SKIPN T
SKIPA AR1,V%TYI
POP P,AR1
PUSHJ P,TIFLOK
TDNN F,F.MODE(TT)
TDZA A,A
MOVEI A,TRUTH
UNLKPOPJ
STERPRI:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
STERP1: SKIPLE FO.LNL(TT)
TDZA A,A
MOVEI A,TRUTH
UNLKPOPJ
SSTERPRI:
CAMN T,XC-1
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
POP P,A
MOVMS FO.LNL(TT)
SKIPE A
MOVNS FO.LNL(TT)
JRST STERP1
;SCRFUN SCRFIL SLOSEF SSLOS0 SSLOSEF BPDLNKJ
SUBTTL STATUS CRFILE, LOSEF
SCRFUN==FALSE ;***** TEMP CROCK *****
SCRFIL: SETZ A,
PUSHJ P,DEFAULTF
HRRZ A,(A)
POPJ P,
SLOSEF: MOVE T,LOSEF
JFFO T,.+1
MOVNS TT
ADDI TT,36.
JRST FIX1
SSLOS0: MOVEI A,(B)
WTA [BAD LOSEF - SSTATUS!]
SSLOSEF:
MOVEI B,(A)
SKIPE GCPSAR
JRST SLOSEF
JSP T,FXNV2
JUMPLE D,SSLOS0
CAILE D,16
JRST SSLOS0
MOVEI TT,1
LSH TT,(D)
SUBI TT,1
MOVEM TT,LOSEF
BPDLNKJ: MOVEI A,(B)
JRST PDLNKJ
;SJCL SJCL2 SJCL4 SDDTP SJCL SJCL1A SJCL1 SJCL2 SJCL4 SJCL3
SUBTTL STATUS JCL, HACTRN
IFN D10,[
SJCL: SKIPN T,SJCLBUF
JRST FALSE
PUSH FXP,T
PUSH FXP,[440700,,SJCLBUF+1]
SJCL2: ILDB TT,(FXP)
PUSHJ P,RDCH2
PUSH P,A
SOSLE -1(FXP)
JRST SJCL2
SJCL4: MOVE T,SJCLBUF
SUB FXP,R70+2
JRST LIST
] ;END OF IFN D10
IFN ITS,[
SDDTP: .SUSET [.RSUPPRO,,TT] ;STATUS HACTRN
JUMPL TT,FALSE ;NIL MEANS NO SUPERIOR
MOVEI A,TRUTH ;T MEANS THE UNKNOWN SUPERIOR
.SUSET [.ROPTION,,TT]
TLNE TT,OPTDDT
MOVEI A,QDDT
TLNE TT,OPTLSP
MOVEI A,QLISP
POPJ P,
SJCL: .SUSET [.ROPTION,,TT]
TLNE TT,OPTBRK
TLNN TT,OPTCMD
JRST FALSE ;EXIT WITH NIL IF NO COMMAND LINE
SETZM JCLBF
MOVE T,[JCLBF,,JCLBF+1]
BLT T,JCLBF+LJCLBF-1
HLLOS JCLBF+LJCLBF-1
.BREAK 12,[..RJCL,,JCLBF]
MOVEI T,JCLBF ;MUST CLEAR BIT 35'S AS DDT MAY SET THEM!!
MOVEI TT,1 ;MASK
SJCL1A: ANDCAM TT,(T) ;TURN OFF BIT 35
CAIGE T,JCLBF+LJCLBF-1 ;DO ALL WORDS IN JCLBF
AOJA T,SJCL1A
PUSH FXP,R70
PUSH FXP,[440700,,JCLBF]
SJCL1: ILDB TT,(FXP)
JUMPE TT,SJCL3
SJCL2: PUSH P,TT
PUSHJ P,RDCH2
EXCH A,(P)
SOS -1(FXP)
CAIE A,↑M ;CAR-RET CAUSES TERMINATION
JRST SJCL1
SJCL4: MOVE T,-1(FXP)
SUB FXP,R70+2
JRST LIST
SJCL3: HRRZ T,(FXP)
CAIE T,JCLBF+LJCLBF-1
JRST SJCL4
MOVEI A,QSJCL
FAC [TOO MUCH JCL - STATUS!]
] ;END OF IFN ITS
;STTYTYPE STTYSIZE STTYS1 STTSZ9 SOSPEED SOSSP9
SUBTTL STATUS TTYSIZE, TTYTYPE, NEWIO OSPEED
IFN ITS,[
STTYTYPE:
TDZA F,F
STTYSIZE:
MOVEI F,1
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
.CALL STTSZ9
.VALUE
UNLOCKI
JUMPN F,STTYS1
MOVE TT,R
JRST FIX1
STTYS1: JSP T,FXCONS
MOVEI B,(A)
MOVE TT,D
JRST CONSFX
STTSZ9: SETZ
SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS
,,F.CHAN(TT) ;CHANNEL #
2000,,D ;VERTICAL SCREEN SIZE
2000,,TT ;HORIZONTAL SCREEN SIZE
402000,,R ;TCTYP
;TTYCOM, TTYOPT, TTYTYP NOT RETRIEVED
;OSPEED - RETURNS TTY OUPUT SPEED VARIABLE
SOSPEED:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
.CALL SOSSP9
.VALUE
UNLOCKI
JRST FIX1
SOSSP9: SETZ
SIXBIT \TTYVAR\
,,F.CHAN(TT)
,,[SIXBIT \OSPEED\]
402000,,TT
] ;END OF IFN ITS
;STTYTYPE STTYSIZE STTYS1 D10TNM
IFN D10,[
STTYTYPE:
IFE SAIL,[
SKIPE T
POPI P,1
JRST 0POPJ ;ALWAYS ZERO (?)
] ;END OF IFE SAIL
IFN SAIL,[
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
PUSHJ P,D10TNM ;GET TTY NUMBER IN D
GETLIN D ;GET LINE CHARACTERISTICS
UNLOCKI
HLRZ T,D
TRZ T,150777 ;MASK OUT ALL NON-TTY-TYPE BITS
JFFO T,.+2
SETZ TT,
JRST FIX1
] ;END OF IFN SAIL
STTYSIZE:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
IFN SAIL,[
;R GETS SIZE, TT GETS WIDTH
MOVE F,[-2,,R] ;COUNT OF ARGS,,ADR OF ARGS
MOVE R,[15,,R] ;TERMINAL SIZE, -1 IF NOT DISPLAY
MOVE D,[6,,D] ;TERMINAL WIDTH (EXCEPT IF NON-ARPA TTY)
TTYSET F, ;DO TERMINAL OPERATIONS
SKIPGE R ;IF USE REAL PAGE LENGTH
MOVE R,FO.RPL(TT)
MOVE TT,D ;LINE LENGTH ENDS UP IN TT
] ;END OF IFN SAIL
MOVE R,FO.RPL(TT) ;GET REAL PAGE LENGTH
IFE SAIL,[
MOVE TT,FO.LNL(TT) ;GET LINEL
ADDI TT,1 ;WIDTH IS 1 MORE THAN LINEL
] ;END IFE SAIL
STTYS1: UNLOCKI
JSP T,FXCONS
MOVEI B,(A)
MOVE TT,R
JRST CONSFX
;;; GET DEC-10 TERMINAL NUMBER INTO D (-1 FOR OWN TERMINAL).
;;; ENTER WITH TTSAR OF FILE OBJECT IN TT.
D10TNM:
IFN SAIL,[
MOVE D,F.CHAN(TT)
SKIPL F.MODE(TT)
DEVNUM D, ;GET DEVICE NUMBER
SETO D, ;ON FAILURE, OR FOR TTY, USE -1
] ;END OF IFN SAIL
IFE SAIL,[
SETO D,
SKIPGE F.MODE(TT) .SEE FBT.CM
POPJ P,
HRRZ D,F.RDEV(TT) ;CONVERT SIXBIT UNIT NUMBER TO OCTAL
REPEAT 3,[
DPB D,[360600,,D]
DPB D,[030300,,D]
TLNN D,700000
LSH D,-3
LSH D,-3
] ;END OF REPEAT 3
ANDI D,777
] ;END OF IFE SAIL
POPJ P,
] ;END OF IFN D10
;STTYTYPE STTYSIZE STTYS1
IFN D20,[
STTYTYPE:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
HRRZ 1,F.JFN(TT)
GTTYP ;GET TTY TYPE
MOVE TT,2
UNLOCKI
JRST FIX1
STTYSIZE:
SKIPN T
SKIPA AR1,V%TYO
POP P,AR1
PUSHJ P,TOFLOK
HRRZ 1,F.JFN(TT)
RFMOD ;READ JFN MODE WORD
LDB R,[.BP TT%LEN,TT] ;GET PAGE LENGTH
LDB TT,[.BP TT%WID,TT] ;GET WIDTH
SETZ 2,
STTYS1: UNLOCKI
JSP T,FXCONS
MOVEI B,(A)
MOVE TT,R
JRST CONSFX
] ;END OF IFN D20
;STTYSCAN STSCN1 SSTTYSCAN SSTSC1 STTYCONS STCON1 SSTTYCONS SSTCO1 SSTC2 SSTC1
SUBTTL STATUS TTYSCAN, TTYCONS, TTYINT
STTYSCAN:
SKIPN T ;GET TTY PRE-SCAN FUNCTION
SKIPA AR1,V%TYI
POP P,AR1
IFN SFA,[
JSP TT,XFOSP
JRST STSCN1
JRST STSCN1
MOVEI A,(AR1)
MOVEI B,QTTYSCAN
SETZ C,
JRST ISTCSH
STSCN1: ] ;END IFN SFA
PUSHJ P,TIFLOK
HRRZ A,TI.BFN(TT)
UNLKPOPJ
SSTTYSCAN:
CAMN T,XC-1 ;SET TTY PRE-SCAN FUNCTION
SKIPA AR1,V%TYI
POP P,AR1
IFN SFA,[
JSP TT,XFOSP ;DO WE HAVE AN SFA?
JRST SSTSC1 ;NOPE
JRST SSTSC1 ;DITTO
POP P,A ;GET THE ARG
JSP T,%NCONS ;TURN IT INTO A LIST
MOVEI C,(A) ;AS THE ARG TO THE SFA
MOVEI B,QTTYSCAN
MOVEI A,(AR1)
JRST ISTCSH
SSTSC1: ] ;END IFN SFA
PUSHJ P,TIFLOK
POP P,A
HRRZM A,TI.BFN(TT)
UNLKPOPJ
STTYCONS:
MOVEI AR1,(A) ;GET ASSOCIATED TTY FILE OF
CAIN AR1,TRUTH ; OPPOSITE DIRECTION, IF ANY
HRRZ AR1,V%TYI ;PREFER INPUT TTY
IFN SFA,[
JSP TT,XFOSP
JRST STCON1
JRST STCON1
MOVEI A,(AR1)
MOVEI B,QTTYCONS
SETZ C,
JRST ISTCSH
STCON1: ] ;END IFN SFA
PUSHJ P,TFILOK ;LEAVES ITS ARGUMENT IN AR1
HRRZ A,FT.CNS(TT) .SEE TTYMOR
UNLKPOPJ
SSTTYCONS:
SKIPE A ;CONS TOGETHER TWO TTY'S INTO
CAIN A,TRUTH ; A SINGLE CONSOLE
EXCH A,B ;PREFER TO SEE NIL OR T SECOND
CAIN A,TRUTH ;PREFER INPUT TTY FOR FIRST ARG
HRRZ A,V%TYI
SFA% MOVEI AR1,(A)
IFN SFA,[
JSP TT,AFOSP ;DO WE HAVE AN SFA?
JRST SSTCO1 ;NOPE
JRST SSTCO1 ;NOPE
MOVEI C,(B) ;YES, PASS THE SECOND ARG AS THE SFA'S ARG
MOVEI B,QTTYCONS ;TTYCONS IS THE OPERATION
JRST ISTCSH
SSTCO1: ] ;END IFN SFA
PUSHJ P,TFILOK
JUMPE B,SSTC1 ;SUNDER THEM IF ONE IS NIL
MOVEI T,TIFLOK
TLNN TT,TTS<IO>
MOVEI T,TOFLOK
UNLOCKI
CAIE B,TRUTH
JRST SSTC2
HRRZ B,V%TYI ;FOR SECOND ARG OF T, USE TTY
TLNN TT,TTS<IO> ; OF NECESSARY DIRECTION
HRRZ B,V%TYO
SSTC2: MOVEI AR1,(B)
PUSHJ P,(T)
HRRZ C,FT.CNS(TT)
HRRZM A,FT.CNS(TT) ;LINK THIS ONE TO THAT ONE
MOVEI TT,FT.CNS
SKIPE C ;IF IT WAS LINKED, UNLINK
SETZM @TTSAR(C) ; ITS FORMER PARTNER
EXCH B,@TTSAR(A) ;LINK THAT ONE TO THIS ONE
JUMPE B,UNLKTRUE ;????? THINK ABOUT ALL THIS?
CAIE B,(A) ;IF IT WAS LINKED, UNLINK
SETZM @TTSAR(B) ; ITS FORMER PARTNER
JRST UNLKTRUE
SSTC1: HRRZ B,FT.CNS(TT) ;GET ASSOCIATED TTY
SETZM FT.CNS(TT) ;UNLINK THAT FROM THIS
MOVEI TT,FT.CNS
SKIPE B ;ONLY UNCONS IF WAS PREVIOUSLY CONSED
SETZM @TTSAR(B) ;UNLINK THIS FROM THAT
JRST UNLKTRUE
;STTYINT SSTTYINT SSTIN1 SSTIN2 SSTIN3 SSTIN4
STTYINT:
CAMN T,XC-1
SKIPA AR1,V%TYI
POP P,AR1
POP P,A
JSP T,CHNV1
MOVE F,TT
PUSHJ P,TIFLOK
ROT F,-1
ADDI TT,FB.BUF(F)
HRRZ A,(TT)
SKIPL F
HLRZ A,(TT)
UNLKPOPJ
SSTTYINT:
CAMN T,XC-2
SKIPA AR1,V%TYI
POP P,AR1
POP P,A
JSP T,PDLNMK
MOVEI B,(A)
POP P,A
JSP T,CHNV1
MOVE F,TT
PUSHJ P,TIFLOK
ROT F,-1
20$ PUSH P,TT ;SAVE TTSAR
ADDI TT,FB.BUF(F)
JUMPL F,SSTIN1
HRLM B,(TT)
20% JRST UNLKTRUE
20$ SKIPA
SSTIN1: HRRM B,(TT)
20% JRST UNLKTRUE
IFN D20,[
POP P,TT ;RESTORE TTSAR
ROT F,1 ;RESTORE CHARACTER
CAIE F,3 ;DON'T ALLOW USE TO ASSIGN ↑C
CAILE F,26. ;TOPS-20 ONLY SUPPORTS TO ↑Z
JRST UNLKTRUE ;RETURN TRUE, BUT DON'T DO TELL THE OP SYS
MOVE T,V%TYI ;ONLY DO FOLLOWING IF *THE* TTY
CAME TT,TTSAR(T) ;CHECK FOR TTSAR OF *THE* TTY
JRST UNLKTRUE
SETZB T,R ;SEARCH FOR A) FREE SLOT, B) EQUIVALENT SLOT
SSTIN2: CAMN F,CINTAB(T) ;EQUIVALENT SLOT?
JRST SSTIN3 ;YES, CODE ASSIGNED SO TAKE SPECIAL ACTION
SKIPN CINTAB(T) ;EMPTY SLOT?
MOVEI R,400000(T) ;YES, REMEMBER WE HAVE ONE
CAIGE T,CINTSZ-1 ;DONE ALL OF TABLE?
AOJA T,SSTIN2 ;NOPE, CONTINUE LOOPING
JUMPE B,UNLKTRUE ;IF TURNING OFF AND DIDN'T FIND IN TAB, DONE
SKIPN R ;FOUND A FREE SLOT?
JRST SSTIN4
MOVEM F,CINTAB-400000(R) ;YES, STORE NEW CHARACTER ASSIGNMENT
CAILE R,400005 ;CONVERT TO 400000+<D20 INTERRUPT CHANNEL>
ADDI R,22
HRLZI 1,(F) ;CHARACTER
HRRI 1,-400000(R) ;INTERRUPT CHANNEL
ATI ;ASSIGN THE CHARACTER TO THE CHANNEL
MOVEI A,TRUTH ;RETURN TRUE
UNLKPOPJ
SSTIN3: JUMPN B,UNLKTRUE ;RETURN IF CHARACTER WAS ALREADY ASSIGNED
SETZM CINTAB(T) ;CLEAR THE TABLE ENTRY
MOVEI 1,(F) ;DEASSIGN THE TERMINAL CODE
DTI
JRST UNLKTRUE ;THEN RETURN TRUE
SSTIN4: UNLOCKI
FAC [NO FREE INTERRUPT CHANNELS - (SSTATUS TTYINT)!]
] ;END IFN D20
;SPDLMAX SSPDLMAX SGCSIZE SSGCSIZE SGCMAX SSGCMAX SGCMIN SSGCMIN SPDLSIZE SPURSIZE SSPCSIZE SPDLROOM SSGP1 SSGP1A SSGP1C SSGP1D SSGP2A
SUBTTL STORAGE SPACE STATUS CALLS
SPDLMAX:
IFN PAGING,[
JSP D,SSGP1 ;0 - STATUS PDLMAX
SSPDLMAX: JSP D,SSGP1 ;1 - SSTATUS PDLMAX
] ;END OF IFN PAGING
.ELSE REPEAT 2, 0 ;0, 1 UNUSED
SGCSIZE: JSP D,SSGP1 ;2 - STATUS GCSIZE
SSGCSIZE: JSP D,SSGP1 ;3 - SSTATUS GCSIZE
SGCMAX: JSP D,SSGP1 ;4 - STATUS GCMAX
SSGCMAX: JSP D,SSGP1 ;5 - SSTATUS GCMAX
SGCMIN: JSP D,SSGP1 ;6 - STATUS GCMIN
SSGCMIN: JSP D,SSGP1 ;7 - SSTATUS GCMIN
SPDLSIZE: JSP D,SSGP1 ;10 - STATUS PDLSIZE
SPURSIZE: SKIPA B,A ;14 - STATUS PURSIZE
SSPCSIZE: JSP D,SSGP1 ;12 - STATUS SPCSIZE
MOVEI D,14 ;FAKE OUT A JSP D,SSGP1
CAIG B,QRANDOM ;LOSE IF BAD SPACE TYPE
CAIGE B,QLIST
JRST SSGPLZ
2DIF SKIPN (B),GTNPS8,QLIST
JRST SSGPLZ
JRST SSGP1A
SPDLROOM:
MOVEI D,20+SPDLMAX+1 ;20 - STATUS PDLROOM
SSGP1: SUBI D,SPDLMAX+1 ;GET CODE NUMBER IN D
MOVEI C,(B) ;YECH - SHUFFLE, SHUFFLE
MOVEI B,(A)
SSGP1A: MOVEI AR1,(B)
CAIN B,QRANDOM ;GET LINEARIZATION BY USING
JRST SSGPLZ ; QRANDOM FOR QARRAY
CAIN B,QARRAY
MOVEI B,QRANDOM
TRNE D,6 ;SKIP IF PDLMAX OR PDLSIZE
JRST SSGP1C
CAIL B,QREGPDL
CAILE B,QSPECPDL
JRST SSGPLZ
JRST SSGP1D
SSGP1C: CAIG B,QRANDOM ;LOSE IF BAD SPACE TYPE
CAIGE B,QLIST
JRST SSGPLZ
SSGP1D: ROT D,-1 ;LOW BIT=1 => SSTATUS
JUMPL D,SSG3A1
MOVE TT,@SSGPGT(D) ;ELSE GET VALUE TO RETURN
TRNE D,3
JRST SSGP2A
2DIF [SUB TT,(B)]C2,QREGPDL ;FOR PDL STUFF, CUT DOWN
TLZ TT,-1 ; QUANTITY BY PDL ORIGIN
SSGP2A: TLNN TT,-1 ;HACK SO THAT STATUS GCMIN
JRST FIX1 ; WILL RETURN A FLONUM
JRST FLOAT1 ; IF APPROPRIATE
;SSGPGT SSGPLZ SSGP3$ SSG3A1 SSGP3A SSGP3Z SSGP3Y SSGPPT SSGM1 SSGM2 SSGMRV SSGP4
SSGPGT:
10% 2DIF (B),XPDL,QREGPDL ;PDLMAX
10$ 0 ;UNUSED
2DIF (B),GFSSIZ,QLIST ;GCSIZE
2DIF (B),XFFS,QLIST ;GCMAX
2DIF (B),MFFS,QLIST ;GCMIN
2DIF (B),P,QREGPDL ;PDLSIZE
2DIF (B),SFSSIZ,QLIST ;SPCSIZE
2DIF (B),PFSSIZ,QLIST ;PURSIZE
0 ;UNUSED
2DIF (B),OC2,QREGPDL ;PDLROOM
SSGPLZ: MOVEI T,SBADSP ;BAD SPACE TYPE (OR MAYBE PDL TYPE?)
TRNN D,6
MOVEI T,[SIXBIT \BAD PDL TYPE - STATUS!\]
MOVEI A,(AR1)
%WTA (T)
MOVEI B,(A)
JRST SSGP1A
SSGP3$: JUMPE C,TRUE ;USED BY $ALLOC
;A CHANGE IN POLICY TO ALWAYS ALLOW A FLONUM
SSG3A1: MOVEI T,(D)
CAIN T,3 ;IF GCMIN,
JRST SSGP4 ; USE SPECIAL CHECKING CODE
SSGP3A: SKOTT C,FL ;ALLOW FLONUM
JRST SSGP3Z
MOVE TT,(C) ;GET THE FLONUM
PUSH FXP,D ;SAVE D OVER CALL TO IFIX
JSP T,IFIX ;CONVERT TO A FIXNUM
POP FXP,D
MOVE R,TT
JRST SSGP3Y ;THEN HANDLE AS IF FIXNUM
SSGP3Z: SKOTT C,FX ;MUST BE FIXNUM
JRST FALSE
MOVE R,(C) ;ELSE FETCH THE FIXNUM
SSGP3Y: TLNE R,-1 ;LOSE IF NEG OR TOO LARGE
JRST FALSE
JRST SSGPPT(D) ;ELSE JRST TO SPECIAL ROUTINE
SSGPPT:
10% JRST SSPM1 ;PDLMAX
10$ 0
JRST SSGS1 ;GCSIZE
JRST SSGX1 ;GCMAX
SSGM1: CAIL R,40 ;GCMIN
2DIF [CAMLE D,(B)]SSGMRV,QLIST ;FIXNUM GCMIN MUST HAVE
JRST FALSE ; "REASONABLE" VALUE
SSGM2:
2DIF [MOVEM R,(B)]MFFS,QLIST ;SO SAVE IT, ALREADY
JRST TRUE
SSGMRV: 20000 ;LIST
10000 ;FIXNUM
4000 ;FLONUM
BG$ 4000 ;BIGNUM
4000 ;SYMBOL
REPEAT HNKLOG+1, 100000 ;HUNKS
1000 ;SAR
SSGP4: MOVEI A,(C) ;(SSTATUS GCMIN ...) PERMITS
JSP T,FLTSKP ; A FLONUM ARGUMENT
JRST SSGP3A
JUMPLE TT,FALSE ;BUT MUST BE POSITIVE
CAML TT,[.005] ; AND BETWEEN .005 AND .95
CAMLE TT,[.95]
JRST FALSE
MOVE R,TT
JRST SSGM2
;SSGS1 SSGX1 SSPM1 CSETP1 CSETNS CSETP2 CSETP3 CSETP7
SSGS1: ANDI R,SEGMSK
2DIF [MOVEM R,(B)]GFSSIZ,QLIST ;SET GCSIZE
2DIF [CAMG R,(B)]XFFS,QLIST ;IF GREATER THAN GCMAX,
JRST TRUE ; MUST ALSO SET GCMAX TO MATCH
SSGX1:
2DIF [CAMGE R,(B)]SFSSIZ,QLIST ;GCMAX MAY NOT BE LESS
JRST FALSE ; THAN ACTUAL SIZE
XCTPRO
2DIF [HRRZM R,(B)]XFFS,QLIST
NOPRO
JRST TRUE
IFN ITS+D20,[
SSPM1: HRRZ T,P-QREGPDL(B) ;GET CURRENT PDL POINTER
ADD R,C2-QREGPDL(B) ;UP USER'S VALUE BY PDL ORIGIN
ANDI R,777760
TRNN R,PAGKSM
SUBI R,20
CAILE R,(T) ;NEW PDLMAX MUST BE ABOVE
CAML R,OC2-QREGPDL(B) ; CURRENT PDL POINTER, AND
JRST FALSE ; BELOW ABS OVERFLOW POINT
HRRZM R,XPDL-QREGPDL(B)
HRRZM R,ZPDL-QREGPDL(B) ;SO UPDATE CRAP
HRROS P-QREGPDL(B) ;SET LH OF PDL POINTER TO -1
JRST TRUE ; SO PDLOV WILL HACK IT PROPERLY
] ;END OF IFN ITS+D20
;;; PART OF PUTPROP - HACK FOR *PURE MODE TO PURIFY PROPERTY LISTS
CSETP1: PUSH P,B
MOVEI A,(C)
MOVE B,VPUTPROP
PUSHJ P,MEMQ ;CALLS THE CHECKING VERSION OF MEMQ
POP P,B
JUMPE A,CSETP7
PUSH P,C ;NEED TO PURCOPY C(C) ALSO
MOVEI A,(B)
PUSHJ P,PURCOPY
EXCH A,(P) ;REMEMBER THE VALUE, GET THE PROPERTY
SKOTT A,SY ;IS THE PROPERTY A SYMBOL?
JRST CSETNS ;NO
HLRZ T,(A) ;POINTER TO THE SY2 BLOCK
MOVE T,SYMVC(T) ;GET THE FLAG BITS
TLNN T,SY.PUR ;IS IT ALREADY PURE?
PUSHJ P,PURCOPY ;NO, PURCOPY IT
CSETNS: POP P,A ;RESTORE THE VALUE TO BE PUT ON THE PROPERTY
MOVE T,(P)
CSETP2: HRRZ B,(T)
JUMPE B,CSETP3
MOVEI TT,(B)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,PUR
JRST CSETP3
HRRZ T,(B)
JRST CSETP2
CSETP3: PUSHJ P,PCONS
MOVEI B,(A)
MOVEI A,(C)
PUSHJ P,PCONS
HRRM A,(T)
SUB P,R70+1
JRST $CADR
CSETP7: HRRZ A,(P)
JRST CSET2A
;SRANDOM SRAND3 SSRAN0 SSRANDOM SSRAN3 SSRAN6 SSRAN8
SUBTTL STATUS RANDOM
SRANDOM:
SETZ B,
MOVEI F,LRBLOCK-1+2 ;+2 FOR RNOWS AND RBACK
SRAND3: MOVE TT,RNOWS(F) ;CONS UP A LIST SUMMARIZING
PUSHJ P,CONSFX ; THE STATE OF THE RANDOM
SOJGE F,SRAND3 ; NUMBER GENERATOR
POPJ P,
SSRAN0: WTA [BAD ARGUMENT - STATUS RANDOM!]
SSRANDOM:
SKOTT A,LS
JRST SSRAN8
MOVEI B,(A)
JSP TT,SSRAN6
MOVEM R,RNOWS
JSP TT,SSRAN6
MOVEM R,RBACK
MOVNI F,LRBLOCK
SSRAN3: HLRZ C,(B)
JSP T,FXNV3
MOVEM R,RBLOCK+LRBLOCK(F)
HRRZ B,(B)
AOJL F,SSRAN3
JRST TRUE
SSRAN6: HLRZ C,(B)
JSP T,FXNV3
JUMPLE R,SSRAN0
CAILE R,LRBLOCK+1
JRST SSRAN0
HRRZ B,(B)
JRST (TT)
SSRAN8: JSP T,FXNV1
SKIPN TT ;0 IS BAD VALUE
MOVEI TT,1
JSP F,IRAND0
JRST TRUE
;SSWHO1 SSWHO2 SSWHO3 SWHO1 SWHO1A SWHO2 SWHO3 SIXNUM
IFN USELESS,[
IFN ITS,[
SUBTTL STATUS WHO-LINE [ETC.]
SSWHO1: SETZ F,
MOVE D,[441000,,F]
JSP T,FXNV1
IDPB TT,D
MOVEI A,(B)
JSP T,CHNV1X
IDPB TT,D
JSP T,FXNV3
IDPB R,D
MOVEI A,(AR1)
JSP T,CHNV1X
IDPB TT,D
.SUSET [.SWHO1,,F]
JRST TRUE
SSWHO2: PUSHJ P,SIXNUM
.SUSET [.SWHO2,,TT]
JRST TRUE
SSWHO3: PUSHJ P,SIXNUM
.SUSET [.SWHO3,,TT]
JRST TRUE
SWHO1: .SUSET [.RWHO1,,F]
MOVEI R,4
SETZ B,
MOVE D,[441000,,F]
SWHO1A: ILDB TT,D
JSP T,FXCONS
PUSHJ P,CONS
MOVEI B,(A)
SOJG R,SWHO1A
JRST NREVERSE
SWHO2: .SUSET [.RWHO2,,TT]
JRST FIX1
SWHO3: .SUSET [.RWHO3,,TT]
JRST FIX1
SIXNUM: SKOTT A,FX
JRST SIXMAK
POP P,T
JRST FXNV1
;SMAR SSMAR SSMAR5 SFTV SSFTV SFTVSIZE SSFTVSIZE SFTVTITLE SSGCWHO
;;; IFN USELESS
;;; IFN ITS
SMAR: MOVE T,IMASK
TRNN T,%PIMAR ;NIL IF LISP NOT USING MAR
JRST FALSE ; (BUT SUPERIOR MIGHT BE)
.SUSET [.RMARA,,D]
HLRZ TT,D
MOVEI A,(D)
PUSHJ P,ACONS
MOVEI B,(A)
JRST CONSFX ;RETURN LIST OF (MODE, LOCATION)
SSMAR: MOVEI F,%PIMAR
JSP T,FXNV1
TRZ TT,4
JUMPE TT,SSMAR5
IORM F,IMASK
.SUSET [.SIMASK,,F]
HRLI B,(TT)
.SUSET [.SMARA,,B]
JRST TRUE
SSMAR5: .SUSET [.SMARA,,R70]
ANDCAM F,IMASK
.SUSET [.SAMASK,,F]
JRST TRUE
SFTV: TDZA AR2A,AR2A ;MOBY I/O CRUD
SSFTV: MOVEI AR2A,1 ;AUTOLOADS FROM COM:NVID FASL
JCALL 5,QSFTV.
SFTVSIZE: MOVEI AR2A,2
JCALL 5,QSFTV.
SSFTVSIZE: MOVEI AR2A,3
JCALL 5,QSFTV.
SFTVTITLE: MOVEI AR2A,4
JCALL 5,QSFTV.
SSGCWHO: JSP T,FXNV1
ANDI TT,3
MOVEM TT,GCWHO
JRST TRUE
;SITS SITS9
;;; IFN USELESS
;;; IFN ITS
SITS: .CALL SITS9
.VALUE
PUSH FXP,T
JSP T,IFLOAT
FDVRI TT,(30.0)
JSP T,FLCONS
SETZ B,
PUSHJ P,CONSIT
POP FXP,TT
PUSHJ P,CONSFX
MOVE TT,D
PUSHJ P,CONSFX
MOVE TT,R
PUSHJ P,CONSFX
MOVE TT,F
JSP T,IFLOAT
SKIPL TT
FDVRI TT,(30.0)
JSP T,FLCONS
JRST CONS
SITS9: SETZ
SIXBIT \SSTATU\
2000,,F ;TIME UNTIL SYSTEM GOES DOWN
2000,,R ;SYSTEM BEING DEBUGGED
2000,,D ;NUMBER OF LOSERS
2000,,T ;NUMBER OF MEMORY ERRORS
402000,,TT ;TIME SYSTEM HAS BEEN UP
] ;END OF IFN ITS
] ;END OF IFN USELESS
;STBA LSSTBA
SUBTTL ASCII TABLE OF STATUS FUNCTIONS
;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 1 *****
STBA: ASCII \MACRO\ ;MACRO
ASCII \DIVOV\ ;DIVOV (DIVIDE OVERFLOW)
ASCII \TTY\ ;TTY
ASCII \TOPLE\ ;TOPLEVEL
ASCII \BREAK\ ;BREAKLEVEL
ASCII \UREAD\ ;UREAD
ASCII \UWRIT\ ;UWRITE
ASCII \+\ ;+ (SUPRA-DECIMAL DIGITS OPTION)
ASCII \GCMIN\ ;GCMIN
ASCII \SYNTA\ ;SYNTAX
ASCII \CHTRA\ ;CHTRAN (CHARACTER TRANSLATION)
ASCII \TTYIN\ ;TTYINT
ASCII \GCTIM\ ;GCTIME
ASCII \LOSEF\ ;LOSEF (LAP OBJECT STORAGE EFFICIENCY FACTOR)
ASCII \TERPR\ ;TERPRI (SUPPRESSION OF AUTO-TERPRI)
ASCII \←\ ;← (CAN PRIN1 USE ← FIXNUM SYNTAX)
ASCII \TTYRE\ ;TTYREAD
ASCII \FEATU\ ;FEATURE
ASCII \NOFEA\ ;NOFEATURE
IFN USELESS, ASCII \ABBRE\ ;ABBREVIATE
ASCII \UUOLI\ ;UUOLINKS
ASCII \GCMAX\ ;GCMAX
IFN PAGING, ASCII \PDLMA\ ;PDLMAX
ASCII \GCSIZ\ ;GCSIZE
ASCII \LINMO\ ;LINMODE
ASCII \CRFIL\ ;CRFILE (CURRENT FILE)
ASCII \CRUNI\ ;CRUNIT (CURRENT UNIT)
ASCII \EVALH\ ;EVALHOOK (FOR MULTICS COMPATIBILITY)
ASCII \TTYSC\ ;TTYSCAN
ASCII \TTYCO\ ;TTYCONS
ASCII \RANDO\ ;RANDOM
IFN USELESS,[
IFN ITS,[
ASCII \WHO1\ ;WHO1 ;ITS WHO-LINE
ASCII \WHO2\ ;WHO2 ; DISPLAY
ASCII \WHO3\ ;WHO3 ; VARIABLES
ASCII \MAR\ ;MAR ;MAR BREAK FEATURE
ASCII \GCWHO\
] ;END OF IFN ITS
] ;END OF IFN USELESS
IFN ITS*USELESS,[
ASCII \FTV\ ;FTV (FAKE TV)
ASCII \FTVSI\ ;FTVSIZE
] ;END OF IFN ITS*USELESS
ASCII \PUNT\ ;PUNT ;TRUE MEANS NO FUNCTIONAL VARIABLES
ASCII \FLUSH\ ;FLUSH ;NON-NIL MEANS FLUSH PAGES UPON
; A SUSPEND
IFN USELESS*ITS, ASCII \CLI\ ;CLI ;DISABLE/ENABLE CLI INTERRUPTS
LSSTBA==.-STBA ;END OF ENTRIES WHICH CAN BE SSTATUS'D
;LSTBA
;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 2 *****
IFN ITS*USELESS, ASCII \FTVTI\ ;FTVTITLE
ASCII \PURSI\ ;PURSIZE
ASCII \PDLSI\ ;PDLSIZE
ASCII \DAYTI\ ;DAYTIME
ASCII \DATE\ ;DATE
IFN USELESS, ASCII \DOW\ ;DOW (DAY OF WEEK)
IT$ ASCII \TTYSI\ ;TTYSIZE (HEIGHT . WIDTH)
ASCII \UNAME\ ;UNAME (USER NAME)
ASCII \USERI\ ;USERID
ASCII \XUNAM\ ;XUNAME
ASCII \JNAME\ ;JNAME (JOB NAME)
ASCII \SUBSY\ ;SUBSYSTEM
ASCII \JNUMB\ ;JNUMBER
ASCII \HOMED\ ;HOMEDIR (HOME DIRECTORY NAME)
ASCII \HSNAM\ ;HSNAME (SMART HOME DIRECTORY NAME)
ASCII \LISPV\ ;LISPVERSION
ASCII \JCL\ ;JCL (JOB COMMAND LINE)
IT$ ASCII \HACTR\ ;HACTRN
ASCII \UDIR\ ;UDIR (USER DIRECTORY NAME)
ASCII \FXPDL\ ;FXPDL (FIXNUM PDL)
ASCII \FLPDL\ ;FLPDL (FLONUM PDL)
ASCII \PDL\ ;PDL (REG PDL)
ASCII \SPDL\ ;SPDL (SPECIAL PDL)
ASCII \BPSL\ ;BPSL (BINARY PROGRAM SPACE LOW)
ASCII \BPSH\ ;BPSH (BINARY PROGRAM SPACE HIGH)
ASCII \SEGLO\ ;SEGLOG (LOG2 OF SEGMENT SIZE)
ASCII \SYSTE\ ;SYSTEM (SYSTEM ATOM)
ASCII \TABSI\ ;TABSIZE
ASCII \SPCNA\ ;SPCNAMES (NAMES OF DATA SPACES)
ASCII \PURSP\ ;PURSPCNAMES
ASCII \PDLNA\ ;PDLNAMES
ASCII \SPCSI\ ;SPCSIZE
ASCII \PDLRO\ ;PDLROOM
ASCII \MEMFR\ ;MEMFREE
ASCII \NEWLI\ ;NEWLINE
ASCII \FILEM\ ;FILEMODE
ASCII \TTYTY\ ;TTYTYPE
IT$ ASCII \OSPEE\ ;OSPEED
ASCII \FASLO\ ;FASLOAD (RETURNS CURRENT LDBSAR)
IFN USELESS,[
IFN ITS,[
ASCII \ITS\ ;ITS
] ;END OF IFN ITS
] ;END OF IFN USELESS
ASCII \STATU\ ;STATUS
ASCII \SSTAT\ ;SSTATUS
ASCII \ARRAY\ ;ARRAY
LSTBA==.-STBA
;
SUBTTL STATUS DISPATCH TABLES
;;; FORMAT <4.9-4.7> , <4.6-3.8> , <2.9-1.1>
.FORMAT 37,002231104103
RADIX 4
;;; MAGIC TABLE OF STATUS OPERATIONS
;;; 4.9-4.7 OPERATION TYPE
;;; 0 SUBR-TYPE FUNCTION
;;; 1 LSUBR-TYPE FUNCTION
;;; 2 SUBR-TYPE WITH CHAR FIRST ARG
;;; 3 LSUBR-TYPE WITH CHAR FIRST ARG
;;; 4 GET LISP VALUE
;;; 5 SET LISP VALUE
;;; 6 SET TO T-OR-NIL
;;; 7 GET FIXNUM VALUE
;;; 4.6-4.5 ARGUMENT 1 TYPE
;;; 0 NO MORE ARGS
;;; 1 QUOTED ARGUMENT
;;; 2 TAKE REST AS QUOTED LIST
;;; 3 EVALUATED ARGUMENT
;;; 4.4-4.3 ARGUMENT 2 TYPE
;;; 4.2-4.1 ARGUMENT 3 TYPE
;;; 3.9-3.8 ARGUMENT 4 TYPE
;;; 3.7-3.1 ARGS INFO
;STBSS LSST
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** SSTATUS FUNCTION TABLE ***** MUST MATCH ASCII TABLE *****
STBSS: 3,1310,SSMACRO (FA23) ;MACRO
6,3000,RWG (FA1) ;DIVOV
IT$ 1,3333,SSTTY (FA1234&1333) ;TTY
20$ 1,3333,SSTTY (FA1N&1333) ;TTY
10$ SA% 1,3333,SSTTY (FA12) ;TTY
10$ SA$ 1,3333,SSTTY (FA1N&1333) ;TTY
5,3000,TLF (FA1) ;TOPLEVEL
5,3000,BLF (FA1) ;BREAKLEVEL
0,2000,UREAD (FA0234);UREAD
0,2000,UWRITE (FA012) ;UWRITE
0,3000,SSPLSS (FA1) ;+
0,3300,SSGCMIN (FA2) ;GCMIN
2,1300,SSSYNTA (FA2) ;SYNTAX
2,1300,SSCHTRA (FA2) ;CHTRAN
1,3330,SSTTYINT (FA23) ;TTYINT
0,3000,SSGCTIM (FA1) ;GCTIME
0,3000,SSLOSEF (FA1) ;LOSEF
1,3300,SSTERPRI (FA12) ;TERPRI
0,3000,SSLAP (FA1) ;←
0,3000,SSTTYREAD (FA1) ;TTYREAD
0,1000,SSFEATURE (FA1) ;FEATURE
0,1000,SSNOFEATURE (FA1) ;NOFEATURE
IFN USELESS, 0,3000,SSABBREVIATE (FA1) ;ABBREVIATE
0,0000,SSUUOLINKS (FA0) ;UUOLINKS
0,3300,SSGCMAX (FA2) ;GCMAX
IFN PAGING, 0,3300,SSPDLMAX (FA2) ;PDLMAX
0,3300,SSGCSIZE (FA2) ;GCSIZE
1,3300,SSLINMODE (FA12) ;LINMODE
20% 0,2000,SSCRFIL (FA2) ;CRFILE
20$ 0,2000,SSCRFIL (FA23) ;CRFILE
0,2000,CRUNIT (FA012) ;CRUNIT
0,3000,FALSE (FA1) ;EVALHOOK
1,3300,SSTTYSCAN (FA12) ;TTYSCAN
0,3300,SSTTYCONS (FA2) ;TTYCONS
0,3000,SSRANDOM (FA1) ;RANDOM
IFN USELESS,[
IFN ITS,[
0,3333,SSWHO1 (FA4) ;WHO1
0,3000,SSWHO2 (FA1) ;WHO2
0,3000,SSWHO3 (FA1) ;WHO3
0,3300,SSMAR (FA2) ;MAR
0,3000,SSGCWHO (FA1) ;GCWHO
] ;END OF IFN ITS
] ;END OF IFN USELESS
IFN ITS*USELESS,[
0,2000,SSFTV (FA0234) ;FTV
0,3000,SSFTVS (FA1) ;FTVSIZE
] ;END OF IFN ITS*USELESS
6,3000,EVPUNT (FA1) ;PUNT
6,3000,SUSFLS (FA1) ;FLUSH
IFN USELESS*ITS, 0,3000,SSCLI (FA1) ;CLI
LSST==.-STBSS
IFN LSST-LSSTBA, WARN [WRONG LENGTH SSTATUS TABLE]
;STBS
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** STATUS FUNCTION TABLE ***** PART 1 (MATCHES STBSS) *****
STBS: 2,1000,SMACRO (FA1) ;MACRO
4,0000,RWG (FA0) ;DIVOV
1,3000,STTY (FA01) ;TTY
4,0000,TLF (FA0) ;TOPLEVEL
4,0000,BLF (FA0) ;BREAKLEVEL
0,0000,SUREAD (FA0) ;UREAD
0,0000,SUWRITE (FA0) ;UWRITE
0,0000,SPLSS (FA0) ;+
0,3000,SGCMIN (FA1) ;GCMIN
2,1000,SSYNTAX (FA1) ;SYNTAX
2,1000,SCHTRAN (FA1) ;CHTRAN
1,3300,STTYINT (FA12) ;TTYINT
0,0000,SGCTIM (FA0) ;GCTIM
0,0000,SLOSEF (FA0) ;LOSEF
1,3000,STERPRI (FA01) ;TERPRI
0,0000,SLAP (FA0) ;←
0,0000,STTYREAD (FA0) ;TTYREAD
0,2000,SFEATURES (FA01) ;FEATURES
0,2000,SNOFEATURE (FA1) ;NOFEATURE
IFN USELESS, 0,0000,SABBREVIATE (FA0) ;ABBREVIATE
0,0000,SUUOLINKS (FA0) ;UUOLINKS
0,3000,SGCMAX (FA1) ;GCMAX
IFN PAGING, 0,3000,SPDLMAX (FA1) ;PDLMAX
0,3000,SGCSIZE (FA1) ;GCSIZE
1,3000,SLINMODE (FA01) ;LINMODE
0,0000,SCRFIL (FA0) ;CRFILE
0,0000,SCRUNIT (FA0) ;CRUNIT
0,0000,FALSE (FA0) ;EVALHOOK
1,3000,STTYSCAN (FA01) ;TTYSCAN
0,3000,STTYCONS (FA1) ;TTYCONS
0,0000,SRANDOM (FA0) ;RANDOM
IFN USELESS,[
IFN ITS,[
0,0000,SWHO1 (FA0) ;WHO1
0,0000,SWHO2 (FA0) ;WHO2
0,0000,SWHO3 (FA0) ;WHO3
0,0000,SMAR (FA0) ;MAR
7,0000,GCWHO (FA0) ;GCWHO
] ;END OF IFN ITS
] ;END OF IFN USELESS
IFN ITS*USELESS,[
0,0000,SFTV (FA0) ;FTV
0,0000,SFTVSIZE (FA0) ;FTVSIZE
] ;END OF ITS*USELESS
4,0000,EVPUNT (FA0) ;PUNT
4,0000,SUSFLS (FA0) ;FLUSH
IFN USELESS*ITS, 0,3000,SCLI (FA0) ;CLI
IFN .-STBS-LSSTBA, WARN [WRONG LENGTH STATUS TABLE PART 1]
;
;;; .FORMAT 37,002231104103
;;; RADIX 4
;;; ***** STATUS FUNCTION TABLE ***** PART 2 (NON-SSTATUS ITEMS) *****
IFN ITS*USELESS,[
0,0000,SFTVTITLE (FA0) ;FTVTITLE
] ;END OF IFN ITS*USELESS
0,3000,SPURSIZE (FA1) ;PURSIZE
0,3000,SPDLSIZE (FA1) ;PDLSIZE
0,0000,STIME (FA0) ;DAYTIME
0,0000,SDATE (FA0) ;DATE
IFN USELESS, 0,0000,SDOW (FA0) ;DOW (DAY OF WEEK)
IT$ 1,3000,STTYSIZE (FA01) ;TTYSIZE
0,0000,SUNAME (FA0) ;UNAME
0,0000,SUSERID (FA0) ;USERID
0,0000,SUSERID (FA0) ;XUNAME
0,0000,SJNAME (FA0) ;JNAME
0,0000,SSUBSYSTEM (FA0) ;SUBSYSTEM
0,0000,SJNUMBER (FA0) ;JNUMBER
IT$ 0,0000,SHOMED (FA0) ;HOMEDIR
IT% 4,0000,SUDIR (FA0) ;HOMEDIR
1,3300,SHSNAME (FA012) ;HSNAME
0,0000,SLVRNO (FA0) ;LISPVERSION
IT$ 0,0000,SJCL (FA0) ;JCL
IT% 4,0000,VNIL (FA0) ;DECSYSTEM-10 HAS NO JCL
20$ WARN [TOPS-20 JCL?]
IT$ 0,0000,SDDTP (FA0) ;HACTRN
4,0000,SUDIR (FA0) ;UDIR
7,0000,FXC2 (FA0) ;FXPDL
7,0000,FLC2 (FA0) ;FLPDL
7,0000,C2 (FA0) ;PDL
7,0000,SC2 (FA0) ;SPDL
7,0000,BPSL (FA0) ;BPSL (ORIGINAL BPS LOW)
7,0000,BPSH (FA0) ;BPS HIGH
7,0000,[SEGLOG] (FA0) ;SEGLOG
0,3000,SSYSTEM (FA1) ;SYSTEM
7,0000,IN10 (FA0) ;TABSIZE
4,0000,[SPCNAMES] (FA0) ;SPCNAMES
4,0000,[PURSPCNAMES] (FA0) ;PURSPCNAMES
4,0000,[PDLNAMES] (FA0) ;PDLNAMES
0,3000,SSPCSIZE (FA1) ;SPCSIZE
0,3000,SPDLROOM (FA1) ;PDLROOM
0,0000,SMEMFREE (FA0) ;MEMFREE
7,0000,IN0+↑M (FA0) ;NEWLINE
0,3000,SFILEMODE (FA1) ;FILEMODE
1,3000,STTYTYPE (FA01) ;TTYTYPE
IT$ 1,3000,SOSPEED (FA01) ;OSPEED
4,0000,LDBSAR (FA0) ;FASLOAD
IFN USELESS,[
IFN ITS,[
0,0000,SITS (FA0) ;ITS
] ;END OF IFN ITS
] ;END OF IFN USELESS
1,1000,SSSS (FA01) ;STATUS
1,1000,SSSSS (FA01) ;SSTATUS
0,0000,SARRAY (FA0) ;ARRAY
IFN .-STBS-LSTBA, WARN [WRONG LENGTH STATUS TABLE PART 2]
RADIX 8
.FORMAT 37,0 ;MAKE FORMAT 37 ILLEGAL AGAIN
;;@ END OF STATUS 194
;CURSORPOS CRSRPS CRSR10 CRSFA5 CRSFAY CRSFA4 CRSFA2 CRSFAZ CRSRP8 CRSFA1 CRSRP0 CRSR20 CRSRP5 CRSRP7 CRSRP3 CRSR40 CRSRP4 CRSRP6 CRSRP9 ZZZ ZZZ CRSR11 CRSR12 CRSR13 CRSR14 CRSRP1 CRSRMP CRSRM1 CRSRN
SUBTTL CURSORPOS FUNCTION
IFN USELESS*ITS,[
CURSORPOS:
MOVEI D,QCURSORPOS ;LSUBR (0 . 3)
CAMGE T,XC-3 ;MORE THAN THREE ARGS LOSES
JRST WNALOSE
JUMPE T,CRSRP0 ;IF NO ARGS, IS FOR DEFAULT TTY
CRSRPS: SKIPN AR1,(P) ;ELSE LAST ARG MAY BE TTY FILE ARRAY
JRST CRSRN
MOVEI TT,(AR1)
LSH TT,-SEGLOG
SKIPGE ST(TT)
JRST CRSRMP
CAIN AR1,TRUTH ;LAST ARG = T
HRRZ AR1,V%TYO ; MEANS THE DEFAULT TTY
CRSR10: CAMN T,XC-3 ;FOR THREE ARGS MUST HAVE A FILE ARRAY
JRST CRSRP8
JSP TT,XFOSP ;FOR ONE OR TWO ARGS MAY OR MAY
JRST CRSRP0 ; NOT HAVE A FILE ARRAY
IFN SFA,[
JRST CRSFA1 ;FILE
CRSFA5: SUB P,R70+1 ;SFA
CRSFAY: SETZ C,
AOJE T,CRSFA2 ;ONE LESS ARG; ONLY 1 ARG, ARG TO SFA IS NIL
POP P,A ;LISTIFY THE ARGS
PUSHJ P,NCONS ;GENERATE THE INITIAL LIST
AOSN T ;TWO ARGS?
JRST CRSFA4
POP P,B
JSP T,%XCONS ;NOW THE LIST IS IN A
CRSFA4: MOVEI C,(A)
CRSFA2: MOVEI B,QCURSORPOS ;CURSORPOS OPERATION
MOVEI A,(AR1) ;THE SFA ITSELF
JRST ISTCSH
CRSFAZ: HRRO AR1,V%TYO ;GET FILE AS SPECIFIED BY 'T'
JSP TT,XFOSP ;CHECK FOR IT BEING A SFA
JRST (F) ;NOPE
JRST (F)
SOJA T,CRSFAY ;A SFA, HANDLE SPECIALLY
] ;END IFN SFA
CRSRP8:
IFN SFA,[
JSP TT,XFOSP ;CHECK IF FILE OR SFA
JFCL
SKIPA ;NOT SFA
JRST CRSFA5 ;SFA
CRSFA1: ] ;END IFN SFA
SUB P,R70+1 ;IF WE HAVE ONE, IT MUST
PUSH FXP,T ; BE A BONA FIDE TTY OUTPUT FILE
PUSHJ P,TOFLOK
UNLOCKI
POP FXP,T
AOSA T
CRSRP0:
SFA% HRRO AR1,V%TYO
SFA$ JSP F,CRSFAZ
JSP R,PDLA2(T)
MOVEI TT,F.MODE
MOVE D,@TTSAR(AR1)
SKIPGE AR1 ;IF FILE NOT EXPLICITLY GIVEN
SKIPN TTYOFF ; THEN ↑W NON-NIL => RETURN NIL
SKIPA
JRST FALSE
JUMPE T,CRSRP1 ;0 ARGS - GET POSITION
AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (↑P CODES)
SKOTT A,FX ;2 ARGS
JRST CRSR11
MOVEI D,"V ;SET VERTICAL POSITION
PUSHJ P,CRSRP5
CRSR20: MOVEI D,"H ;SET HORIZONTAL POSITION
MOVEI A,(B)
CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE
JSP T,FXNV1
SKIPGE TT
SETZ TT, ;NEGATIVE ARG NOT ALLOWED
CAILE TT,167 ;NOR ARG ABOVE 167
MOVEI TT,167
HRLI D,10(TT) ;ADD MAGIC 10 TO AMOUNT FOR ↑P
CRSRP7: .5LKTOPOPJ .SEE INTTYR
.SEE CNPCOD
MOVEI A,NIL ;RETURN NIL BY DEFAULT
HLLOS NOQUIT
MOVE T,TTSAR(AR1)
.CALL VAROPT ;GET TTY INFO
JRST CZECHI ;IF FAILURE THEN ASSUME CAN'T DO ANYTHING
XCT CNPOK-"A(D) ;CHECK IF LEGAL FOR THIS TYPE OF TTY
JRST CZECHI ;NOPE, SO RETURN NIL
MOVEI A,TRUTH ;RETURN TRUTH IF WE GOT THIS FAR
JRST CNPCUR ;THIS UNDOES THE LOCKING STUFF
CRSRP3: JSP T,SPATOM ;IF SYMBOL, USE FIRST CHAR
JRST CRSRP4
PUSHJ P,CRSR40
JRST CRSRP6
CRSR40: JSP T,CHNV1
CAIL TT,140
SUBI TT,40 ;CONVERT TO UPPER CASE
POPJ P,
CRSRP4: JSP T,FXNV1 ;ELSE BETTER BE FIXNUM
CRSRP6: MOVEI D,(TT)
TRC TT,100
TDNE TT,[-40]
JRST CRSRP2
MOVE TT,GCBT(TT)
TDNN TT,CRSRP9
JRST CRSRP2
JRST CRSRP7
CRSRP9:
ZZZ==0
IRPC X,,[ABCDEFKLMNTUXZ[\]↑←]
ZZZ==ZZZ\<SETZ←-<"X&37>>
TERMIN
ZZZ ;BITS SPECIFYING VALID ↑P CODES
EXPUNGE ZZZ ;NOTE: H, I, AND V NOT VALID HERE!
CRSR11: JUMPE A,CRSR20
JSP T,SPATOM
JRST CRSR12
PUSHJ P,CRSR40
JSP T,FXNV2
SKIPGE D
SETZ D,
CAIE TT,"H
CAIN TT,"V
JRST CRSR13
CAIN TT,"I
JRST CRSR14
CRSR12: WTA [BAD CURSOR CODE - CURSORPOS!]
JRST CRSR11
CRSR13: CAILE D,167
MOVEI D,167
ADDI D,10 ;H AND V RANDOMLY WANT 10 ADDED
CRSR14: MOVSI D,400000(D) .SEE CNPCD1 ;KEEP LH FROM BEING ZERO
HRRI D,(TT)
JRST CRSRP7
CRSRP1: PUSHJ P,FORCE1
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
MOVEI TT,F.CHAN
.CALL RCPOS ;GET CURRENT CURSOR POSITION
.LOSE 1400
TLNE F,FBT<EC> ;GET ECHO MODE POSITION
MOVE D,R ; IF FILE IS FOR ECHO AREA
MOVEI TT,(D) ;CONS THEM UP FOR LOSER
JSP T,FIX1A
MOVEI B,(A)
HLRZ TT,D
JSP T,FIX1A
JRST CONS
CRSRMP: PUSH FXP,T
CRSRM1: HLRZ A,@(P)
MOVE T,(FXP)
MOVEI TT,(T)
ADDI TT,(P)
PUSH P,1(TT)
TRNE T,1
PUSH P,2(TT)
PUSH P,A
PUSHJ P,CRSRPS
HRRZ A,@(P)
MOVEM A,(P)
JUMPN A,CRSRM1
POP FXP,T
CRSRN: MOVEI A,TRUTH
JRST PROGN1
] ;END OF IFN USELESS*ITS
;%%FUNCTION .FUNC4 .FUNC1 .FUNC2 .FUNC3 AEVAL
SUBTTL RANDOM ROUTINES TO HANDLE A PSEUDO ALIST
%%FUNCTION: MOVEI D,Q%%FUNCTION
JUMPE A,WNAFOSE
HRRZ C,(A)
JUMPN C,.FUNC1
HLRZ B,(A) ;HALF-ASSED FUNARG BINDING
HRROI TT,(SP) ;ONE LH AS GOOD AS ANOTHER
JSP T,FIX1A
PUSHJ P,XCONS
.FUNC4: MOVEI B,QFUNARG
JRST XCONS
.FUNC1: HLRZ AR2A,(A)
HLRZ AR1,(C)
HRRZ C,(C)
JUMPN C,WNAFOSE
.FUNC2: JUMPE AR1,.FUNC3
HLRZ A,(AR1)
JSP T,SPATOM
JSP T,PNGE1
HLRZ B,(A)
HLRZ B,@(B)
PUSHJ P,CONS
MOVEI B,(C)
PUSHJ P,CONS
HRRZ AR1,(AR1)
JRST .FUNC2
.FUNC3: MOVEI A,(C)
MOVEI B,TRUTH
PUSHJ P,NRECONC
MOVEI B,(AR2A)
PUSHJ P,CONS
JRST .FUNC4
AEVAL: SKIPE A,(P) ;PURPOSELY CRIPPLING POWER OF ALIST
JSP T,FXNV1 ; ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;EVAL WITH AN ALIST
SUB P,R70+1
POP P,A
SKIPE T ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
POPJ FXP,
;ALIST ALST1
;;; ALIST CREATES AN ENVIRONMENT AS SPECIFIED BY A GIVEN A-LIST.
;;; AN A-LIST MAY BE:
;;; [1] NIL, MEANING THE TOP-LEVEL ENVIRONMENT.
;;; [2] T, MEANING THE CURRENT ENVIRONMENT (SEE [4]).
;;; [3] A FIXNUM REPRESENTING A SPECPDL POINTER, AS
;;; RETURNED BY THE EVALFRAME FUNCTION AS THE FOURTH
;;; ITEM. THIS INDICATES THE ENVIRONMENT AS OF
;;; THE SPECIFIED FRAME.
;;; [4] ((<SYMBOL> . <VALUE>) . <A-LIST>)
;;; THAT IS, ONTO ONE OF THE OTHER THREE KINDS OF A-LIST
;;; ONE MAY CONS ADDITIONAL VARIABLE-VALUE PAIRS IN
;;; THE USUAL MANNER. THIS IS A "TRUE A-LIST".
;;; THIS ENVIRONMENT IS CREATED BY REBINDING ALL VARIABLES
;;; WHICH HAVE BEEN BOUND SINCE THEN BACK TO THEIR OLD VALUES,
;;; OR TO THE VALUES SPECIFIED BY THE TRUE A-LIST. IF A GIVEN
;;; VARIABLE WAS BOUND SEVERAL TIMES, ONLY ONE REBINDING IS DONE
;;; TO RECREATE THE OLD ENVIRONMENT. THIS IS DONE BY USING THE
;;; LEFT HALF OF A VALUE CELL TO INDICATE WHETHER OR NOT IT
;;; HAS ALREADY BEEN REBOUND. THIS HAS THE CONSEQUENCE THAT
;;; NOQUIT MUST BE TURNED ON DURING THIS OPERATION.
;;; EITHER ONE OR TWO SPECPDL BLOCKS ARE PUSHED, THE SECOND ONE
;;; BEING NECESSARY IF ANY TRUE A-LIST IS GIVEN. THERE ARE FOUR
;;; STEPS TO THE PROCESS:
;;; [1] CHECK ARGUMENT THOROUGHLY FOR ERRORS. IF A TRUE
;;; A-LIST IS GIVEN, ALL SYMBOLS ON THE A-LIST ARE GIVEN
;;; VALUE CELLS IF THEY DON'T HAVE ANY ALREADY.
;;; [2] TURN ON NOQUIT. IF A TRUE A-LIST IS GIVEN, BIND ALL
;;; THE SYMBOLS AS SPECIFIED, MARKING THE VALUE CELLS
;;; AS THEY ARE BOUND, AND NEVER BINDING A SYMBOL TWICE.
;;; WHEN DONE, PUSH THE TRUE A-LIST ONTO THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [3] SCAN THE SPECPDL FROM THE POINT SPECIFIED BY THE
;;; SPECPDL POINTER (FROM THE BOTTOM IF NIL), AND BIND
;;; ALL VALUES CELLS SEEN BACK TO THEIR OLD VALUES,
;;; MARKING THEM AS THEY ARE BOUND, NEVER BINDING ONE
;;; TWICE. WHEN DONE, PUSH A POINTER ON THE SPECPDL
;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY.
;;; [4] SCAN BACK OVER ALL THE ITEMS PUSHED IN STEPS 2
;;; AND 3, RESTORING THE LEFT HALVES OF ALL THE VALUE
;;; CELLS. TURN OFF NOQUIT AND CHECK FOR INTERRUPTS.
;;; ON RETURN, A-LIST LEAVES T NON-ZERO IFF TWO BIND BLOCKS
;;; WERE PUSHED. IT IS UP TO THE CALLER TO MAKE SURE THAT THE
;;; BLOCK(S) ARE UNBOUND CORRECTLY WITH AUNBIND.
;;; NOTE THAT ERRPOP CAN RECOGNIZE THESE SPECIAL BIND BLOCKS AND
;;; CALL AUNBIND TO UNBIND THEM. THIS IS BECAUSE THE LAST WORD
;;; PUSHED HAS ZERO IN THE LEFT HALF.
ALIST: SKIPN C,-1(P) ;MAKE COPY OF ENVIRONMENT GIVEN A-LIST
ALST1: JUMPE C,ALST3 ;STEP 1 - ERROR CHECKING
CAIN C,TRUTH
JRST ALST3 ;T AND NIL ARE VALID A-LISTS
SKOTT C,LS
JRST ALST2 ;NOPE - GO CHECK IT OUT
HLRZ AR1,(C) ;YUP - CHECK ITS CAR
HRRZ C,(C)
SKOTT AR1,LS
JRST ALST0
HLRZ A,(AR1)
SKOTT A,SY
JRST ALST0
CAIN A,TRUTH
JRST ALST0
HLRZ AR1,(A)
HRRZ B,(AR1)
MOVEI AR1,QUNBOUND
CAIN B,SUNBOUND
JSP T,.SET1
JRST ALST1
;ALST2 ALST3 ALST3A ALST4 ALST4A ALST4C ALST5 ALST5A AL5AB
ALST2: TLNN TT,FX ; - DARN WELL BETTER BE A FIXNUM
JRST ALST0
HRRZ TT,(C) ;MUST BE A VALID SPECPDL POINTER
CAML TT,ZSC2
CAILE TT,(SP)
JRST ALST0
ALST3: HLLOS NOQUIT ;TURN ON NOQUIT - MUSTN'T INTERRUPT
HLLOS MUNGP ;ABOUT TO MUNG VALUE CELLS!
MOVEM SP,SPSV ;STEP 2 - PUSH BLOCK FOR TRUE A-LIST
SETZ T, ;T WILL BECOME NON-ZERO IF TRUE
SKIPN C,-1(P) ; A-LIST IS PRESENT AT ALL
ALST3A: JUMPE C,ALST4 ;NIL FOUND
CAIN C,TRUTH
JRST ALST7 ;T FOUND
SKOTT C,LS
JRST ALST4A ;FIXNUM FOUND
HLRZ B,(C)
HRRZ C,(C)
HLRZ A,(B) ;A HAS ATOMIC SYMBOL
HRRZ AR1,(B) ;AR1 HAS ASSOCIATED VALUE
HLRZ B,(A)
HRRZ A,(B)
SKIPGE AR2A,(A) ;SKIP UNLESS VALUE CELL MARKED
JRST ALST3A ;VALUE CELL ALREADY REBOUND
HRLI AR2A,(A) ;PUSH <VALUE CELL,,CURRENT VALUE>
PUSH SP,AR2A ; ONTO SPECPDL; THEN INSTALL
HRROM AR1,(A) ; VALUE FROM ENVIRONMENT, MARKING CELL
AOJA T,ALST3A ;T NON-ZERO => WE PUSHED SOMETHING
ALST4: MOVEI C,SC2 ;NIL => TOP LEVEL ENVIRONMENT
ALST4A: HRRZ C,(C) ;FIXNUM => SPECIFIED ENVIRONMENT
HRRZ B,SPSV
JUMPE T,ALST4C ;IF ANYTHING PUSHED, START NEW BLOCK
PUSH SP,-1(P) ;LEFT HALF BETTER BE ZERO!
PUSH SP,SPSV ;FINISH OFF BLOCK FOR TRUE A-LIST
MOVEM SP,SPSV ;START NEW BLOCK FOR FUNARG POINTER
ALST4C: MOVEI TT,(C) ;STEP 3 - SCAN SPECPDL FROM ENVIRONMENT
ALST5: CAIN TT,(B) ; BACK UP TO POINT WHEN ALIST CALLED
JRST ALST6
HRRZ AR1,(TT) ;GET VALUE FROM SPECPDL
CAMGE AR1,ZSC2 ;IGNORE SPECPDL POINTERS
JRST ALST5A
CAIGE AR1,(SP)
AOJA TT,ALST5
ALST5A: HLRZ A,(TT) ;GET VALUE CELL FROM SLOT
JUMPE A,AL5AB ;IGNORE FROBS ALIST PUSHES!
SKIPGE AR2A,(A) ;IGNORE MARKED VALUE CELLS
AL5AB: AOJA TT,ALST5
HRLI AR2A,(A) ;ELSE PUSH AS BEFORE
PUSH SP,AR2A
HRROM AR1,(A)
AOJA TT,ALST5
;ALST7 ALST6 ALST6A ALST6B ALST7A AUNBIND AUNBN0 AUNBN1 AUNBN2 AUNBN3 AUNBN4 AUNBN5 AUNBN6 AUNBN7
ALST7: HRRZ C,-1(P) ;T => CURRENT ENVIRONMENT
SETZ T, ;ONLY ONE BLOCK PUSHED
HRRZ B,SPSV
ALST6: PUSH SP,C ;STEP 4 - RESTORE VALUE CELLS
ALST6A: CAIN B,(SP)
JRST ALST7A
HLRZ A,(B)
JUMPE A,ALST6B
CAMGE A,ZSC2
HRRZS (A)
ALST6B: AOJA B,ALST6A
ALST7A: PUSH SP,SPSV ;CLOSE BIND BLOCK
HLLZS MUNGP ;VALUE CELLS UNMUNGED
JRST CZECHI ;ALL DONE - CHECK INTERRUPTS
;;; AUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST.
;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF
;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST,
;;; CLOBBERING CURRENT VALUES FROM VALUE CELLS INTO SPECPDL
;;; SLOTS OR A-LIST SLOTS AS APPROPRIATE, SO THAT ANY SETQ'S
;;; DONE IN THE CREATED COPY OF THE ENVIRONMENT WILL BE
;;; REFLECTED IN THE ORIGINAL ENVIRONMENT.
AUNBIND:
POP SP,T
AUNBN0: MOVEM TT,UNBND3
MOVEM D,AUNBD
MOVEM R,AUNBR
MOVEM F,AUNBF
MOVEI F,1(T)
HRRZ R,(SP)
CAMGE R,ZSC2
JRST AUNBN4
AUNBN1: CAIN F,(SP) ;CLOBBER SETQ'S BACK INTO SPECPDL
JRST AUNBN3
HLRZ D,(F)
AUNBN2: HLRZ TT,(R)
CAIE TT,(D)
AOJA R,AUNBN2
HRRZ TT,(TT)
HRRM TT,(R)
AOJA F,AUNBN1
AUNBN3: MOVE F,AUNBF
MOVE R,AUNBR
MOVE D,AUNBD
SUB SP,R70+1
JRST UNBND0
AUNBN4: ;CLOBBER SETQ'S BACK INTO TRUE A-LIST
AUNBN5: CAIN F,(SP)
JRST AUNBN3
HLRZ D,(F)
JRST AUNBN7
AUNBN6: HRRZ R,(R)
AUNBN7: HLRZ TT,(R)
HLRZ TT,(TT)
HLRZ TT,(TT)
HRRZ TT,(TT)
CAIE TT,(D)
JRST AUNBN6
HLRZ TT,(R)
HRRZ D,(D)
HRRM D,(TT)
AOJA F,AUNBN5
;IAP4A APFNG CAUNBIND APLBL APLBL1
IAP4A: MOVEM TT,R ;AT THIS POINT, WE MAKE UP AN
HRROI TT,(SP)
JSP T,FIX1A
PUSH P,A
MOVE TT,R
MOVNI R,2
MOVNI T,1
JRST IAP5
APFNG: HRRZ A,(B) ;APPLY FUNARG
HLRZ B,(B)
HRRM B,(C)
PUSH P,A
MOVEM T,APFNG1
PUSHJ P,ALIST
PUSH P,.
HRROI TT,-2(P)
MOVE D,APFNG1
POP TT,2(TT)
AOJLE D,.-1
CAUNBIND:
MOVEI D,AUNBIND
MOVEM D,2(TT)
SKIPN T
MOVEI D,CPOPJ
MOVEM D,1(TT)
MOVE T,APFNG1
JRST IAPPLY
APLBL: HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
MOVEM SP,SPSV ;APPLY LABEL EXPRESSION
PUSHJ P,BIND
PUSHJ P,ABIND3
MOVEI A,APLBL1
EXCH A,-1(C)
HLLM A,-1(C)
PUSH FXP,A
JRST IAPPLY
APLBL1: PUSHJ P,UNBIND
POPJ FXP,
;LISTIFY LFY3 LFY1 PNPUT $PNGET $PNG.R $PNG3 $PNG3A $PNG4 $PNG.D $PNGX
SUBTTL LISTIFY, PNPUT, AND PNGET
LISTIFY:
SKIPN R,ARGLOC
JRST LFYER
JSP T,FXNV1 ;LISTIFY UP N ARGS FOR AN LSUBR
MOVM D,TT
CAMLE D,@ARGNUM
JRST LFY0
JUMPGE TT,LFY3
ADD R,@ARGNUM
SUBI R,(D)
LFY3: HRLOI TT,(D) ;SEE HAKMEM (A.I. MEMO 239) ITEM 156
EQVI TT,(R) ;TT GETS <-N-1>,,<CONTENTS OF ARGLOC>
AOBJP TT,FALSE ;ZERO ARGS
PUSH P,R70
MOVEI R,(P) ;T HOLDS LAST POINTER
LFY1: MOVE A,(TT) ;GET ARG
JSP T,PDLNMK
PUSHJ P,NCONS
HRRM A,(R) ;CLOBBER ONTO END OF LIST
MOVEI R,(A) ;ADVANCE LAST POINTER
AOBJN TT,LFY1
JRST POPAJ
PNPUT: JUMPE B,SYCONS
PUSH P,A
SETZM LPNF
JRST INTRN1
$PNGET: PUSHJ P,PNGET
MOVE C,A
JSP T,FXNV2
MOVEI B,0
CAIN TT+1,7
POPJ P,
CAIE TT+1,6
LERR [SIXBIT \FEATURE NOT YET IMPLEMENTED - PNGET!\]
TDZA D,D
$PNG.R: PUSHJ P,CONSFX
SETZ TT,
MOVE R,[440600,,TT]
$PNG3: TLNN D,760000
JRST $PNG.D
$PNG3A: TLNN R,740000
JRST $PNG.R
$PNG4: ILDB T,D ;GET NEXT ASCII BYTE
JUMPE T,$PNGX
CAIGE T,140 ;CHECK FOR LOWER-CASE
ADDI T,40 ;CONVERT, AND STORE
IDPB T,R
JRST $PNG3
$PNG.D: JUMPE C,$PNGX
HLRZ F,(C) ;CONSTRUCT WORD OF ASCII, AND BPTR THERETO
MOVE F,(F)
HRRZ C,(C)
MOVE D,[440700,,F]
JRST $PNG3A
$PNGX: JUMPE TT,.+2
PUSHJ P,CONSFX
JRST NREVERSE
;DEPOSIT EXAMINE MAKNUM MUNKAM
SUBTTL EXAMINE, DEPOSIT, MAKNUM, MUNKAM
DEPOSIT: ;FIRST ARG IS FIXNUM ADDRESS, 2ND IS VALUE
EXCH A,B
JSP T,FXNV2 ;GET ADR INTO TT+1
JSP T,FLTSKP ;GET DATA INTO TT
JFCL
MOVEM TT,(TT+1) ;PERFORM DEPOSIT
JRST TRUE
EXAMINE:
PUSH P,CFIX1
JSP T,FXNV1
MOVE TT,(TT)
POPJ P,
MAKNUM: MOVEI TT,(A)
JRST FIX1
MUNKAM: JSP T,FXNV1
MOVEI A,(TT)
POPJ P,
;$SLEEP ALARMCLOCK ALCK3 ALCK4 ALCK1 ALCK5 ALCK7 ALCK2 M30.
SUBTTL SLEEP, LISTEN, ALARMCLOCK
;;; (SLEEP <N>) SLEEPS FOR <N> SECONDS. <N> MAY BE A FIXNUM OR FLONUM.
$SLEEP: JSP T,FLTSKP ;SUBR 1
IT% CAIA
IT$ JSP T,M30.
IT$ FMPR TT,[30.0]
JSP T,IFIX
IT$ .SLEEP TT, ;SLEEP FOR <TT> 30TH'S OF A SECOND
10$ SLEEP TT, ;SLEEP FOR <TT> SECONDS
IFN D20,[
IMULI TT,1000.
SPECPRO INTSLP ;MUST PROTECT THIS IN CASE OF INTERRUPTS
MOVE 1,TT ;(A) WE WANT TO ALLOW INTERRUPTS TO GO THROUGH
DISMS ;(B) WE MUST BEWARE OF CRUD IN AC 1
XCTPRO
SETZ 1,
NOPRO
] ;END OF IFN D20
JRST TRUE
IFN ITS,[
ALARMCLOCK:
EXCH A,B
SETO TT,
CAIE B,Q$RUNTIME
JRST ALCK1
JUMPE A,ALCK3 ;NIL => TURN OFF CLOCK
JSP T,FLTSKP ;RUN TIME IN MICROSECONDS,
JRST .+2 ; ACCURATE TO 4. USEC JIFFIES
JSP T,IFIX
ASH TT,-2
ALCK3: .SUSET [.SRTMR,,TT]
ALCK4: JUMPL TT,FALSE
JRST TRUE
ALCK1: CAIE B,Q$TIME
JRST ALCK0
JUMPE A,ALCK5 ;NIL => TURN OFF CLOCK
JSP T,FLTSKP ;REAL TIME IN SECONDS,
JSP T,M30. ; ACCURATE TO 30TH'S
FMPRI TT,(30.0)
JSP T,IFIX
ASH TT,1
ALCK5: MOVSI R,400000
JUMPL TT,ALCK2
JUMPN TT,ALCK7
MOVEI TT,1 ;IF 0 SPECIFIED, USE 1/30 SECOND
ALCK7: MOVE R,[600000,,TT]
ALCK2: .REALT R,
JRST ALCK4
M30.: IMULI TT,30. ;NOTE: DOUBLE SKIP RETURN
JRST 2(T)
] ;END OF IFN ITS
;REMOB REMOB2 REMOB7 REMOB3 REMOB4 REMOB1 ARG ARGXX ARG3 SETARG ARGCOM
SUBTTL REMOB, ARG, SETARG
REMOB: JSP T,SPATOM ;SUBR 1 - REMOVE ATOMIC SYMBOL FROM OBARRAY
JSP T,PNGE ;ERROR IF ARG NOT A SYMBOL
LOCKI
PUSHJ P,INTERN
JRST REMOB7
REMOB2: LOCKI
REMOB7: EXCH A,B ;OBTBL BUCKET # SHOULD BE IN TT
MOVE R,TT
HRRZ D,VOBARRAY
HRRI TT,@TTSAR(D)
PUSHJ P,ARYGT4
HLRZ T,(A)
CAIN T,(B)
JRST REMOB1
REMOB3: MOVE D,A
HRRZ A,(A)
HLRZ T,(A)
CAIE T,(B)
JRST REMOB3
HRRZ T,(A)
HRRM T,(D)
REMOB4: HLRZ TT,(B) ;LEAVE ATOM HEADER IN T
HRRZ TT,1(TT) ;LEAVE PNAME LINK IN TT
JSP T,GCP8L ;CHECK TO SEE THAT SCOS ARE REMOVED FROM SCO TABLE.
SETZB A,B
UNLKPOPJ
REMOB1: HRRZ A,(A)
JSP T,.STOR0
JRST REMOB4
ARG: JUMPE A,ARG3 ;SUBR 1 - FETCH LSUBR ARGUMENT
ARGXX: JSP R,ARGCOM
HRRZ A,(D)
JRST PDLNKJ
ARG3: SKIPN ARGLOC ;(ARG NIL) RETURNS NUMBER OF LSUBR ARGUMENTS
JRST ARGCM1
HRRZ A,ARGNUM
JRST PDLNKJ
SETARG: JSP R,ARGCOM ;SUBR 2 - SET LSUBR ARGUMENT
MOVE A,B
JSP T,PDLNMK
HRRM A,(D)
POPJ P,
ARGCOM: SKIPN D,ARGLOC
JRST ARGCM0
JSP T,FXNV1
JUMPLE TT,ARGCM8
CAMLE TT,@ARGNUM
JRST ARGCM8
ADD D,TT
JRST (R)
;SBSYM VCLSYM VCSYM TLSYM TSYM PLSYM PSYM POF TOF PSYM1
SUBTTL P.$X AND FRIENDS
10% DEPURE: JSR POFF ;DEPURIFY A PAGE
10% REPURE: JSR POFF ;REPURIFY A PAGE
SBSYM: JSR POFF ;FIND SUBR NAME (ADR IN RH OF .)
VCLSYM: JSR POFF ;FIND ATOM FOR VC (ADR IN LH OF .)
VCSYM: JSR POFF ;FIND ATOM FOR VALUE CELL
TLSYM: JSR POFF ;PRINT ST ENTRY OF LEFT HALF OF A CELL
TSYM: JSR POFF ;ST ENTRY OF RIGHT HALF
PLSYM: JSR POFF ;PRINT LEFT HALF OF A CELL
PSYM: JSR POFF ;PRINT RIGHT HALF OF A CELL
POF: JSR POFF ;PRINT ARG (POINTER AT LOC 40)
TOF: JSR POFF ;ST ENTRY OF ARG (POINTER IN 40)
IT$ P%OFF: JSR POFF ;FOR % TYPEOUT MODE IN DDT
10% PPTBL: JSR POFF ;PRINT OUT PURTBL
10% PPPAG: JSR POFF ;PRINT OUT ACTUAL PAGE STATUSES
;POFF: 0
PSYM1: SETOM PSYMF
MOVEM T,PSMTS ;P.$X, DONE IN DDT,
MOVEM R,PSMRS ; WILL PRINT CONTENTS
MOVEI T,LPSMTB ; OF CURRENT OPEN CELL
MOVE R,@PSMTB-1(T) ; IN LISP FORMAT.
MOVEM R,PSMS-1(T)
SOJN T,.-2
IFE ITS,[
10$ HRRZ T,.JBDDT"
10$ HRRZ T,@6(T) ;WHAT A KLUDGE! 6?!!
20$ MOVEI T,60 ;TERRIBLE KLUDGE! 60
10$ CAIG R,POF
MOVEM T,PS.S
] ;END OF IFE ITS
HRRZ T,POFF
10% CAIG T,REPURE+1
10% JRST PUFY
PUSH P,CPSYMX
JSP T,ERSTP
MOVEM P,ERRTN
HRRZ R,POFF
IFN ITS,[
MOVEI T,40
MOVEM T,PS.S
MOVEI T,THIRTY+7
CAIN R,P%OFF+1
MOVEM T,PS.S
CAIG R,POF
.BREAK 12,PSMST
] ;END OF IFN ITS
JSP T,SPECBIND
TTYOFF
TAPWRT
V.RSET
10% V.NOPOINT ;FOR PPTBL
IFN USELESS, SETZM TYOSW
HRRZ AR1,V%TYO ;UPDATE OUR NOTION OF THE
PUSHJ P,TTYBR1 ; LINENUM AND CHARPOS OF THE TTY,
MOVEI TT,AT.LNN ; SINCE DDT HAS SCREWED IT ALL UP.
HLRZM D,@TTSAR(AR1)
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(AR1)
;;; FALLS THRU
;PSYMP PSYMQ PSYMX CPSYMX PSYMP1 PSYMSB FCN.B
;;; FALLS IN
HRRZ T,POFF
10% CAIL T,PPTBL+1
10% JRST PPTBL1
MOVE T,PSMTS ;AT THIS POINT ALL ACS WILL HAVE BEEN
MOVE R,PSMRS ; RESTORED SO THAT MOVE A,@ WILL WORK.
MOVE A,PSMS
MOVE AR1,PSMS+AR1-A
MOVE A,@PS.S ;THUS THIS STUFF WORKS IF . IS AN AC.
HRRZ T,POFF
IT$ CAIN T,P%OFF+1
IT$ JRST PSYMP1
CAIN T,POF+1
MOVEI T,PSYM+1
CAIN T,TOF+1
MOVEI T,TSYM+1
SUBI T,SBSYM
TRNE T,1
TLZA A,-1
HLRZS A
LSH T,-1
JRST .+1(T)
JRST PSYMSB ;SB.$X
JRST PSYMVC ;VC.$X AND VCL.$X
JRST PSYMT ;T.$X AND TL.$X AND TP FOO$X
PSYMP: PUSHJ P,PRIN1 ;P.$X AND PL.$X AND PP FOO$X
PSYMQ: MOVEI A,TRUTH ;RETURN POINT TO GET OUT OF PSYM1
JRST ERR2
PSYMX: MOVEI T,LPSMTB
MOVE R,PSMS-1(T)
MOVEM R,@PSMTB-1(T)
SOJN T,.-2
MOVE T,PSMTS
MOVE R,PSMRS
SETZM PSYMF
CPSYMX: POPJ P,PSYMX
IFN ITS,[
PSYMP1: TLNN A,-1 ;LISP MODE TYPEOUT - HACK TWO HALVES
JRST PSYMP
PUSH P,A
HLRZ A,A
PUSHJ P,PRIN1
MOVEI A,", ;SEPARATE HALVES WITH ",,"
REPEAT 2, PUSHJ P,TYO
POP P,A
TLZ A,-1
JRST PSYMP
] ;END OF IFN ITS
PSYMSB: MOVEI B,(A)
PUSHJ P,ERRADR ;ERRADR DOES ALL THE DIRTY WORK!
JRST PSYMQ
FCN.B: SKIPE NOQUIT ;FAKE CONTROL-B INTERRUPT FROM DDT
POPJ P,
SKIPGE INTFLG
POPJ P,
;;; FALLS THRU
;TOF1 POF1 PSYMVC PSVC1 PSVC2 PSVC3 PUFY
;;; FALLS IN
PUSH FXP,D
MOVE D,INHIBIT ;CROCK SO THAT A .5LOCKI
AOJE D,POPXDJ ; WON'T STOP US
PUSH FXP,INHIBIT
SETZM INHIBIT
MOVE D,[TTYIFA,,400000+↑B]
PUSHJ P,UINT
POP FXP,INHIBIT
POP FXP,D
POPJ P,
TOF1: SKIPA T,[TOF]
POF1: MOVEI T,POF
PUSH P,UUOH
EXCH T,UUTSV
JRST @UUTSV
PSYMVC: MOVEI T,(A)
MOVEI A,QUNBOUND
CAIN T,SUNBOUND
JRST PSYMP
SKOTT T,LS
JRST PSVC1
JSP R,GCGEN
PSVC2
PSVC1: MOVEI A,QM
JRST PSYMP
PSVC2: HLRZ A,(D)
HLRZ B,(A)
HRRZ A,(B)
CAIN A,(T)
JRST PSVC3
HRRZ D,(D)
JUMPN D,PSVC2
JRST GCP8A
PSVC3: HLRZ A,(D)
JRST PSYMP
IFE D10,[
PUFY:
IT$ .BREAK 12,PSMST
MOVEI TT,@PS.S ;PURIFY THE PAGE THAT . IS ON
MOVE TT+1,TT ;USED BY DP≠X AND RP≠X
MOVEI C,-REPURE(T)
JSP R,IP0
JRST PSYMX
] ;END OF IFE D10
;ZZ PSMTB LPSMTB P. PL. VC. VCL. T. TL. SB. BB PSYMT PSYMT1 PSYMT2 PSYMT3 PSYMTT PSYMTL
;;; TABLE OF CELLS TO SAVE OVER THE PSYM FUNCTIONS
ZZ==. ;BE SURE TO SEE PSMS IF YOU CHANGE THIS TABLE
PSMTB: ;ACCUMULATOR A MUST BE THE FIRST ITEM, AND AR1 THE FOURTH
IRP FOO,,[A,B,C,AR1,AR2A,TT,D,F,40,UUOH,UUTSV,UUTTSV,UURSV,ERBDF,FPTEM]
FOO
TERMIN
IFN USELESS,[
PRINLV
TYOSW
ABBRSW
] ;END OF IFN USELESS
LPSMTB==.-ZZ ;FPTEM AND PCNT ARE SAME LOCATION
IT$ PSMST: 4,,PS.S-1 ;READ VALUE OF . FROM DDT WITH .BREAK 12,
; PP - A UUO ;PP IS FOR PRINTING OUT AN ADDRESS AS AN S-EXPRESSION:
;PP 34722$X IN DDT WILL PRINT OUT 34722 AS A
; POINTER IN LIST FORMAT.
; TP - A UUO ;TP IS LIKE PP BUT NICELY PRINTS ST ENTRY FOR
; THAT CELL
P.=PUSHJ P,PSYM ;P.$X IS LIKE PP FOO$X WHERE FOO IS RH OF.
PL.=PUSHJ P,PLSYM ;LIKE P., BUT FOR LH OF CURRENT CELL
IT$ P%=PUSHJ P,P%OFF ;LIKE P., BUT AS A DDT TYPEOUT MODE
VC.=PUSHJ P,VCSYM ;FIND NAME OF VALUE CELL RH OF . ADDRESSES
VCL.=PUSHJ P,VCLSYM ;A CROSS BETWEEN VC. AND PL.
T.=PUSHJ P,TSYM ;A CROSS BETWEEN P. AND TP
TL.=PUSHJ P,TLSYM ;A CROSS BETWEEN PL. AND TP
SB.=PUSHJ P,SBSYM ;FIND NAME OF SUBR ADDRESSED BY RH OF .
10% TBLPUR=PUSHJ P,PPTBL ;PRINT OUT PURTBL IN NICE FORM
10% PAGPUR=PUSHJ P,PPPAG ;PRINT OUT ACTUAL STATUS OF PAGES
BB=PUSHJ P,FCN.B ;FAKE CONTROL-B INTERRUPT FROM DDT
IT$ DP=PUSHJ P,DEPURE ;DEPURIFY PAGE . IS ON
IT$ RP=PUSHJ P,REPURE ;REPURIFY PAGE . IS ON
; ENDCODE [P.$X]
SUBTTL T.$X AND TBLPUR$X STUFF
PSYMT: PUSHJ P,ITERPRI ;T.$X TYPEOUT, ETC.
MOVEI TT,(A)
ROT TT,-SEGLOG
MOVE TT,ST(TT)
SETZB T,C
MOVNI R,22
PSYMT1: LSHC T,1
TRZN T,1
JRST PSYMT3
MOVEI A,"+
TROE C,1
PUSHJ P,TYO
MOVEI B,PSYMTT+22(R)
CAIL B,PSYMTT+PSYMTL
MOVEI B,[ASCII \??\]
HRLI B,440700
PSYMT2: ILDB A,B
JUMPE A,PSYMT3
PUSHJ P,TYO
JRST PSYMT2
PSYMT3: AOJL R,PSYMT1
MOVEI A,",
REPEAT 2, PUSHJ P,TYO
HLRZ A,TT
PUSHJ P,PRINC
JRST PSYMQ
.SEE LS ;THIS TABLE SHOULD BE KEPT CONSISTENT
.SEE ST ; WITH TWO OTHER PLACES
PSYMTT:
IRP TP,,[LS,$FS,FX,FL,BN,SY,SA,VC,$PDLNM,??,$XM,$NXM,PUR,HNK,DB,CX,DX]
ASCII \TP\
TERMIN
PSYMTL==.-PSYMTT
;PPTBL1 PPTBL2 PPTBL6 PPTBL3 PPTBL4 PPTBL5 PPTBL7 PPTBL9 PPTBL8
IFN ITS+D20,[
PPTBL1: MOVEI F,-PPTBL-1(T) ;0 => TBLPUR$X, 1 => PAGPUR$X
JSP T,0PUSH-5
MOVE R,[440200,,PURTBL]
MOVEI T,1
PPTBL2: MOVEM T,-4(FXP)
ILDB TT,R
JUMPE F,PPTBL6
IFN ITS,[
.CALL PPTBL8
.VALUE
ASH TT,-41
TRZ TT,1
SKIPGE TT
MOVEI TT,1 ;0=NONX, 1=IMPURE, 2=PURE
] ;END OF IFN ITS
IFN D20,[
MOVEI 1,-1(T)
HRLI 1,.FHSLF
RPACS
SETZ TT,
TLNN 2,(PA%PEX)
JRST PPTBL6
AND 2,[PA%RD+PA%WT+PA%EX+PA%CPY]
MOVEI TT,1
TLNN 2,(PA%WT)
SKIPA TT,[2]
MOVEI TT,1
] ;END OF IFN D20
PPTBL6: MOVEI A,(FXP)
SUBI A,(TT)
AOS (A)
MOVEI A,"0(TT)
PUSHJ P,TYO
MOVE T,-4(FXP)
TRNE T,7
AOJA T,PPTBL2
TRNN T,30
JRST PPTBL3
MOVEI A,40
PUSHJ P,TYO
MOVE T,-4(FXP)
TRNE T,10
AOJA T,PPTBL2
PUSHJ P,TYO
PUSHJ P,TYO
JRST PPTBL4
PPTBL3: PUSHJ P,ITERPRI
MOVE T,-4(FXP)
CAIN T,NPAGS
JRST PPTBL5
PPTBL4: TLZ R,770000
MOVE T,-4(FXP)
AOJA T,PPTBL2
PPTBL5: MOVEI R,TYO
MOVNI TT,4
PPTBL7: EXCH TT,(FXP) ;OKAY, QUUX, IF YOU EVER LOOK AT THIS CODE
JUMPE TT,PPTBL9 ; AGAIN YOU SHOULD HANG YOUR HEAD IN SHAME
MOVEI A,↑I ; FOR EVER HAVING WRITTEN SUCH BARFUCIOUS
PUSHJ P,TYO ; KLUDGY MEANDERINGS! JUNE 16, 1979 -JONL-
MOVE A,(FXP)
ADDI A,"4
PUSHJ P,TYO
%NEG%
MOVEI C,10.
PUSHJ P,PRINI2
POP FXP,TT
PPTBL9: AOJL TT,PPTBL7
POPI FXP,1
JRST PSYMQ
IFN ITS,[
PPTBL8: SETZ
SIXBIT \CORTYP\
1000,,-1(T)
402000,,TT
] ;END OF IFN ITS
] ;END OF IFN ITS+D20
;XPURIFY PURIFY FPURF2 IPUR1 IPUR2
SUBTTL PURIFY≠G ROUTINE
IFN ITS,[
XPURIFY: ;ENTRY POINT TO SETUP A PURQIX
MOVE T,[SIXBIT \PURQIX\];CHANGE SYSFN1 TO BE A PURQIX
MOVEM T,SYSFN1
MOVE T,[SIXBIT \DSK\] ;NEW DEVICE NAME
MOVEM T,SYSDEV
MOVE T,[SIXBIT \LISP\] ;AND FINALLY, NEW SNAME
MOVEM T,SYSSNM
MOVEI T,FEATEX ;SPLICE 'EXPERIMENTAL' INTO FEATURES LIST
MOVEM T,FEATURES
] ;END IFN ITS
IFN ITS+D20,[ ;DOESN'T REALLY WORK FOR D10 YET
PURIFY: JRST NOTINIT ;CLOBBERED BY INIT TO "SETO AR1,"
; SETO AR1, ;FOR PURIFY$G FROM DDT
MOVE P,[-LFAKP-1,,FAKP-1]
JRST FPURF7
FPURF2: SETZB TT,PRSGLK ;ZERO PURE SEGMENT AOBJN PTR
MOVE R,[NPFFS,,NPFFS+1] ;ZERO PURE FREE STORAGE COUNTERS
SETZM NPFFS
BLT R,NPFFY2
MOVSI R,400000
SETZM LDXLPC ;CLEAR # WORDS FREE SO ALWAYS GRAB NEW SET
; OF SEGMENTS THE FIRST TIME A LINK IS NEEDED
; START NEW LIST OF SEGMENTS
SETOM LDXPFG ;SET PURE FLAG
20$ HRLI TT,.FHSLF
MOVNI R,NPAGS ;SO STEP THROUGH LOSING PURTBL
MOVE D,[440200,,PURTBL] ; TO DECIDE HOW TO MUNG PAGES
IPUR1: ILDB T,D ;GET BYTE FOR NEXT PAGE
JRST .+1(T)
JRST IPUR3 ;0 - DELETE
JRST IPUR4 ;1 - IMPURIFY
JRST IPUR6 ;2 - PURIFY
MOVEI T,400(R) ;3 - HAIRY STUFF - DECODE FURTHER
LSH T,PAGLOG
CAMGE T,BPSL ;CODE 3 SHOULD NEVER APPEAR
.VALUE ; BELOW BINARY PROGRAM SPACE
MOVE F,@VBPORG ;PAGIFY CURRENT VALUE OF
ANDI F,PAGMSK ; BPORG DOWNWARD
CAIGE T,(F) ;ANY CODE 3 PAGE BELOW THAT CAN
JRST IPUR6A ; BE PURIFIED
CAMG T,BPSH ;ANY CODE 3 PAGE BETWEEN BPORG
JRST IPUR2 ; AND BPSH IS LEFT AS IS
CAMG T,HINXM ;ANY PAGE BETWEEN BPSH AND HINXM
.VALUE ; DAMN WELL BETTER BE 0!!!
HRRZ F,PDLFL1 ;ANYTHING BETWEEN HINXM AND
LSH F,PAGLOG ; PDLS MUST BE PURE FREE STORAGE
CAIGE T,(F)
JRST IPUR6A
CAIGE T,BSCRSG ;SCRATCH PAGES ARE IGNORED
JUMPL AR1,IPUR3A ;PDL PAGES MAY OR MAY NOT BE FLUSHED, DEPENDING ON AR1
IPUR2:
IT$ ADDI TT,1001
20$ ADDI TT,1
TLNN D,730000 ;ONLY 20 2-BIT BYTES PER WORD, NOT 22
TLZ D,770000
AOJL R,IPUR1
20$ SETZB B,C ;ZERO OUT CRUD
MOVEI A,TRUTH
JUMPGE AR1,POP1J
MOVE T,[STDMSK]
MOVEM T,IMASK
IT$ MOVE T,[STDMS2]
IT$ MOVEM T,IMASK2
IFN ITS,[
.VALUE [ASCIZ \:≠PURIFIED≠
\]
JRST .-1
] ;END OF IFN ITS
IFN D20,[
HRROI 1,[ASCIZ \:$PURIFIED$
\]
PSOUT
HALTF
JRST .-3
] ;END OF IFN D20
;IPUR3A IPUR3 IPUR4 IPUR5 IPUR6A IPUR6 IPUR7 IPUR9
;;; IFN ITS+D20
;;; VARIOUS PAGE FLUSHING AND PURIFYING ROUTINES FOR PURIFY
;DELETE A PAGE
IPUR3A: SKIPE NOPFLS ;NOPFLS NON-ZERO => DON'T FLUSH PAGES
JRST IPUR2
DPB NIL,D ;ZERO OUT PURTBL ENTRY
IPUR3:
IFN ITS,[
TRZ TT,400000
.CBLK TT,
.VALUE
] ;END OF IFN ITS
IFN D20,[
SETO 1,
MOVE 2,TT
HRLI 2,.FHSLF
SETZ 3,
PMAP
] ;END OF IFN D20
JRST IPUR2
;MAKE PAGE WRITABLE
IPUR4:
IFN ITS,[
.CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPL T,IPUR2 ;ALREADY IMPURE
IOR TT,[4400,,400000]
JUMPG T,IPUR5
.CBLK TT, ;NON-EXISTENT - GET A FRESH PAGE
.VALUE
JRST IPUR2
IPUR5: TLZ TT,4000 ;PURE - TRY TO DEPURIFY
.CBLK TT,
JSP F,IP1 ;IF WE LOSE, TRY COPYING
] ;END OF IFN ITS
IFN D20,[
MOVE 1,TT
HRLI 1,.FHSLF
RPACS
TLZE 2,(PA%PEX) ;FORGET IT, IF THE PAGE DOESN'T EXIST
TLOE 2,(PA%CPY+PA%WT) ; OR IF IT IS ALREADY WRITEABLE
JRST IPUR2
AND 2,[PA%RD+PA%WT+PA%EX+PA%CPY]
MOVE 1,TT
HRLI 1,.FHSLF
SPACS
] ;END OF IFN D20
JRST IPUR2
;MAKE PAGE READ-ONLY
IPUR6A: MOVEI T,2 ;CHANGE PURTBL ENTRY TO 2
DPB T,D
IPUR6:
IFN ITS,[
.CALL IPUR9 ;CHECK TYPE OF PAGE
.VALUE
JUMPG T,IPUR2 ;ALREADY PURE
JUMPE T,IPUR7 ;CAN'T PURIFY A NON-EXISTENT PAGE
TLZ TT,4400 ;PURIFY AN IMPURE PAGE
TRO TT,400000
.CBLK TT,
IPUR7: .VALUE
] ;END OF IFN ITS
IFN D20,[
MOVE 1,TT
HRLI 1,.FHSLF
RPACS
TLCE 2,(PA%PEX)
TLZN 2,(PA%WR+PA%CPY)
JRST IPUR2
MOVE 1,TT
HRLI 1,.FHSLF
AND 2,[PA%RD+PA%WT+PA%EX+PA%CPY]
SPACS
] ;END OF IFN D20
JRST IPUR2
IFN ITS,[
IPUR9: SETZ
SIXBIT \CORTYP\
1000,,400(R)
402000,,T
] ;END IFN ITS
] ;END OF IFN ITS+D20
;RSXTB2 RCT0
SUBTTL PURE COPY OF THE READ SYNTAX TABLE
-1,,0 ;FOR NEWRD WILL POINT TO MACRO CHAR LIST
RSXTB2: PUSH P,CFIX1
JSP TT,1DIMF
NIL ;SHOULD NEVER ACTUALLY CALL
0
RCT0:
IFE NEWRD,[ ;OLD VERSION OF PURE READTABLE
IFN SAIL,[
400500,,0 ;NULL IS IGNORED
REPEAT 10, 2,,1+.RPCNT ;SAIL CHARS
500500,,↑I ;TAB
500500,,↑J
400500,,↑K
400500,,↑L
400500,,↑M ;CR
REPEAT 22, 2,,↑N+.RPCNT ;SAIL CHARS
] ;END IFN SAIL
.ELSE,[
REPEAT 10, 400500,,.RPCNT ;↑@ ↑A ↑B ↑C ↑D ↑E ;↑F ↑G
2,,↑H ;↑H
500500,,↑I ;TAB
REPEAT 7, 400500,,↑J+.RPCNT ;↑J ↑K ↑L ↑M ↑N ↑O ↑P
405540,,QCTRLQ ;↑Q
400500,,↑R ;↑R
405540,,QCTRLS ;↑S
REPEAT 7, 400500,,↑T+.RPCNT ;WORTHLESS
2,,33 ;ALT MODE
REPEAT 4, 400500,,↑\+.RPCNT ;WORTHLESS
] ;END IFE SAIL
500500,,40 ;SPACE
REPEAT 6, 2,,"!+.RPCNT ;! " # $ % &
404500,,QRDQTE ;'
440500,,"( ;(
410500,,") ;)
2,,"* ;*
10,,"+ ;+
404500,,QI%C%F ;, (INTERNAL-COMMA-FUN)
50,,"- ;-
420700,,". ;.
402500,,"/ ;/
REPEAT 10., 4,,"0+.RPCNT ;DECIMAL DIGITS
2,,": ;:
404540,,QRDSEMI ;;
REPEAT 5, 2,,"<+.RPCNT ;< = > ? @
REPEAT 26., 1,,"A+.RPCNT ;ALPHABETIC
REPEAT 3, 2,,133+.RPCNT ;SQUARE BRACKTES
22,,"↑ ;CARET
62,,"← ;UNDERSCORE
404500,,QI%B%F ;GRAVE (INTERNAL-BACKQUOTE-FUN)
REPEAT 26., 501,,"A+.RPCNT ;SMALL LETTERS
2,,173 ;LEFT BRACE
404500,,QRDVBAR ;VERTICAL BAR
REPEAT 2, 2,,175+.RPCNT ;RIGHT BRACE, TILDE
401500,,177 ;RUBOUT
IFN .-RCT0-200, WARN [READTABLE LOSSAGE]
402500,,57 ;PSEUDO SLASHIFIER CHARACTER
440500,,50 ;PSEUDO OPEN PARENS
410500,,51 ;PSEUDO CLOSE PARENS
500540,,40 ;PSEUDO SPACE
IFN SAIL,[
REPEAT 74, 400500,,204+.RPCNT ;SAIL CONTROLIFIED FUNNY CHARACTERS
REPEAT 2, 400500,,300+.RPCNT ;↑@ ↑A
400500,,302 ;↑B
REPEAT 5, 400500,,300+.RPCNT ;↑C ↑D ↑E ↑F ↑G
2,,300+↑H ;↑H
500500,,300+↑I ;TAB
REPEAT 7, 400500,,300+↑J+.RPCNT ;↑J ↑K ↑L ↑M ↑N ↑O ↑P
405540,,QCTRLQ ;↑Q
400500,,300+↑R ;↑R
405540,,QCTRLS ;↑S
REPEAT 7, 400500,,300+↑T+.RPCNT ;WORTHLESS
2,,33 ;ALT MODE
REPEAT 444, 400500,,300+↑\+.RPCNT ;WORTHLESS
IFN .-RCT0-1000, WARN [SAIL RCT0 LOSSAGE -- WRONG LENGTH TABLE]
] ;END IFN SAIL
] ;END OF IFE NEWRD
;;; MORE ON NEXT PAGE
;TLRCT ZZ
IFN NEWRD,[ ;NEW VERSION OF PURE READTABLE
REPEAT 11, RS.BRK+RS.SL1+RS.SL9 + .RPCNT ;WORTHLESS CONTROL CHARS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 11 ;TAB
REPEAT 21, RS.BRK+RS.SL1+RS.SL9 + 12+.RPCNT ;WORTHLESS
RS.XLT + 33 ;ALTMODE
REPEAT 4, RS.BRK+RS.SL1+RS.SL9 + 34+.RPCNT ;WORTHLESS
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;SPACE
REPEAT 6, RS.XLT + 41+.RPCNT ;! " # $ % &
RS.BRK+RS.SL1+RS.SL9+RS.MAC + 47 ;'
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;(
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;)
RS.XLT + 52 ;*
RS.SL1+RS.SGN + 53 ;+
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 54 ;,
RS.SL1+RS.SGN+RS.ALT + 55 ;-
RS.BRK+RS.SL1+RS.SL9+RS.DOT+RS.PNT + 56 ;.
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;/
REPEAT 10., RS.SL1+RS.DIG + 60+.RPCNT ;0 - 9
RS.XLT + 72 ;:
RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.ALT + 73 ;;
REPEAT 5, RS.XLT + 74+.RPCNT ;< = > ? @
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D
RS.LTR + RS.SQX + 105 ;E
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z
REPEAT 3, RS.XLT + 133+.RPCNT ;LBRACK BSLASH RBRACK
RS.ARR+RS.XLT + 136 ;↑
RS.ARR+RS.ALT+RS.XLT + 137 ;←
RS.XLT + 140 ;ACCENT GRAVE
REPEAT 4, RS.LTR + 101+.RPCNT ;A-D L.C.
RS.LTR+RS.SQX + 105 ;E L.C.
REPEAT 21., RS.LTR + 106+.RPCNT ;F-Z L.C.
REPEAT 4, RS.XLT + 173+.RPCNT ;LBRACE VBAR RBRACE TILDE
RS.BRK+RS.SL1+RS.SL9+RS.RBO + 177 ;RUBOUT
RS.BRK+RS.SL1+RS.SL9+RS.SLS + 57 ;PSEUDO SLASH
RS.BRK+RS.SL1+RS.SL9+RS.LP + 50 ;PSEUDO (
RS.BRK+RS.SL1+RS.SL9+RS.RP + 51 ;PSEUDO )
RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;PSEUDO SPACE
] ;END OF IFN NEWRD
TLRCT==<.-RCT0>
SA$ INFORM [READTABLE LENGTH = ]\LRCT
ZZ==LRCT-TLRCT
IFE NEWRD,[
IFL ZZ-1-2, INFORM READER-TABLE-DEFICIENCY,\<3-ZZ>
.ELSE BLOCK ZZ-3
] ;END OF IFE NEWRD
NIL,,NIL ;UNUSED
TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE)
NIL,,TRUTH ;(STATUS TERPRI),,(STATUS ←)
;;; TTYREAD=NIL => ONLY FORCE FEED CHARS LET READ SEE THE TTY BUFFER
;;; ABBREVIATE: 1.1 => ABBREV FILES, 1.2 => ABBREV FLATSIZE/EXPLODE
;;; TERPRI=T => DO NOT OUTPUT AUTOMATIC NEWLINES
;;; ←=T => ALLOW PRIN1/PRINC TO OUTPUT FIXNUMS IN FORM M←N
;.NOPOINT CTY TYOI CTYP TYO1C TYO1TB
SUBTTL TOP PAGE PGTOP, AND SOME INSRTS
MOVEI 1,[.] ;THIS WASTEFUL HAC IS MERELY TO INSURE THAT THE LAST
MOVEI 2,[.] ;FEW CONSTANTS ON THIS PART ARE WORTHLESS
MOVEI 3,[.] ;IN CASE THERE ARE MORE ON PASS2 THAN PASS1
PGTOP TOP,[TOPLEVEL, COMMON, AND RANDOM STUFF]
;;; HERE IS A SUNDER HAC - IT MUST BE ABLE TO FIND
;;; <LF>$INSRT<SP>NAME<TABS-OR-SPACES>;COMMENTS ON FILE
;;@ PRINT 231 PRINT AND FILE-HANDLING FUNCTIONS
;;; ***** MACLISP ****** PRINT AND FILE-HANDLING FUNCTIONS *******
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL FUNNY PRINTING ROUTINES
PGBOT PRT
.NOPOINT:
PUSHJ P,NOTNOT
HRRZM A,V.NOPOINT
POPJ P,
COMMENT | HERE IS A FINE HACK THAT GOT SUPERSEDED BY CTYP
CTY: PUSHJ P,TYOI ;THIS IS ALWAYS DONE BY A XCT "Q,CTY - FOR RANDOM Q.
TYOI: PUSH P,A ; USEFUL MAINLY BECAUSE IT SAVES A. WARNING!!!
MOVE A,-1(P) ; THIS CODE IS VERY HACKISH, DEPENDENT ON THE OPCODE
LDB A,[270600,,-1(A)] ; OF XCT (256). THIS ONLY WORKS FOR ASCII
PUSHJ P,(R) ; CHARS IN THE RANGE 40-57. THUS Q MUST BE AMONG
JRST POPAJ ; [ !"#$%&'()*+,-./] (THE BRACKETS ARE META-CHARS!)
| ;END OF COMMENT
;;; XCT N,CTYP
;;; CAUSES THE N'TH CHARACTER IN TYO1TB TO GET PRINTED VIA
;;; THE ROUTINE IN R. SYMBOLS ARE DEFINED FOR THESE XCT'S.
CTYP: PUSHJ P,TYO1C
TYO1C: PUSH P,A
HRRZ A,-1(P)
LDB A,[270400,,-1(A)]
MOVE A,TYO1TB(A)
PUSHJ P,(R)
JRST POPAJ
TYO1TB:
IRP X,,[#,(,),+,-,.,/,|,:,;, ,←,E,D,⊃,.]Z,,[NMBR,LPAR,RPAR,POS
NEG,DOT,SLSH,VBAR,CLN,SEMI,SPC,BAK,E,D,CTLQ,DCML]
%!Z!%=XCT .IRPCNT,CTYP
"X
TERMIN
IFG .-TYO1TB-20, WARN [TOO MANY TYO1TB CHARACTERS]
;PRNARG PRNAR$ PRNAR0 PRNAR3 PRNAR7 PRNTTY PRNAR2 PRNAR4 PRNAR5 PRNAR6 PRNARA PRNAR8 PRNAR9 PNAGX CPNAGX
SUBTTL NEWIO TYO FUNCTION AND RELATED ROUTINES
;;; CALLED BY FUNCTIONS LIKE PRINT WHICH TAKE AN ARG AND
;;; AN OPTIONAL ASCII OUTPUT FILE ARRAY. DOES ARGS CHECKING
;;; AND SETS UP AR1 WITH THE CORRECT OUTPUT FILE(S).
;;; IF ONE ARG IS GIVEN AND THERE ARE NO FILES TO OUTPUT TO
;;; (↑W IS NON-NIL, AND EITHER ↑R OR OUTFILES IS NIL),
;;; THEN A POPJ IS DONE, RETURNING FOR THE CALLING FUNCTION.
;;; LEFT HALF BITS IN AR1:
;;; 400000 RH OF AR1 HAS SINGLE FILE ARRAY (ELSE LIST)
;;; 200000 DO *NOT* OUTPUT TO TTY AS WELL
;;; IFN SFA, THEN ALSO PRINT/PRINC/PRIN1/TYO BIT
;;;
;;; CALLED BY:
;;; JSP F,PRNARG
;;; XXX,,[QPRINT] ;ATOM FOR WNA ERROR
;;; -OR- XXX,,[<SFA-BIT>,,QPRINT] ;IFN SFA
;;; XXX IS TYPICALLY JFCL. IF XXX IS NEGATIVE, THE RETURN VALUE
;;; FOR THE FUNCTION IS NIL INSTEAD OF T.
PRNARG: AOJN T,PRNAR2
POP P,A
PRNAR$: SAVE AR1 AR2A CPNAGX
PRNAR0: SKIPE AR1,TAPWRT ;IF ↑R NOT SET, USE NIL
HRRZ AR1,VOUTFILES ;OTHERWISE USE OUTFILES
JUMPN AR1,PRNAR3
SKIPE TTYOFF
JRST PRNAR8
PRNAR3:
SFA$ HLRZ T,@(F) ;PLACE OPERATIONS FLAG IN AR1
SFA$ TLO AR1,(T)
TRNN AR1,-1
SFA$ JRST PRNTTY ;GOING TO THE TTY
SFA% JRST 1(F)
PUSHJ P,MPFLOK
JRST 1(F)
PRNAR7: PUSHJ P,OFCAN
EXCH A,AR1
PUSHJ P,[IOL [LOSING OUTPUT FILE SPECS!]]
EXCH A,AR1
JUMPE T,PRNAR0
JRST PRNAR4
IFN SFA,[
PRNTTY: TLNE AR1,200000 ;REALLY GOING TO THE TTY?
JRST 1(F) ;NOPE, SO RETURN
MOVSI T,AS.SFA ;IS C(TYO) AN SFA?
MOVE R,V%TYO
TDNN T,ASAR(R)
JRST 1(F) ;NOPE, SO ALL IS OK
HLLZ T,@(F) ;SFA OPERATION MASK
MOVEI TT,SR.WOM
TDNN T,@TTSAR(R) ;CAN THE SFA DO THIS OPERATION DIRECTLY?
JRST 1(F) ;NOPE, IT WILL HANDLER A LOWER-LEVEL THING
MOVEI C,(A) ;ARG IS THING TO PRINT/PRINC/PRIN1
MOVEI AR1,(R) ;THE SFA
JRST ISTCAL ;DO AN INTERNAL SFA CALL
] ;END IFN SFA
PRNAR2: CAME T,XC-1
JRST PRNAR9
MOVE A,-1(P)
MOVEM AR1,-1(P)
EXCH AR2A,(P)
PUSH P,CPNAGX
SKIPN AR1,AR2A
AOJA T,PRNAR0
PRNAR4: JSP T,PRNARK
JRST PRNARA ;ERRONEOUS FILE
JRST PRNAR6 ;LIST OF SOME KIND
SFA$ SKIPA ;NORMAL RETURN
SFA$ JRST PRNAR8 ;HANDLED THE SFA
PRNAR5: TLO AR1,600000 ;VALID FILE OBJECT
HLRZ T,@(F)
TLO AR1,(T)
JRST 1(F)
PRNAR6: TLO AR1,200000
JRST PRNAR3
PRNARA: TLO AR1,200000 ;MAKE ERROR MESSAGE PRINT CORRECTLY
JRST PRNAR7
PRNAR8: SKIPGE (F)
JRST FALSE
JRST TRUE
PRNAR9: HRRZ D,@(F)
JRST S1WNAL
PNAGX: RSTR AR2A AR1
CPNAGX: POPJ P,PNAGX
;MPFLOK MPFLO1 MPFLO3 MPFLO2 PRNARK PRNRK3 PRNRK1 PRNRK2 PRTSTO PRTSO1 PRTSTR PRTST1 PRTST2 PRTSTL
;;; CHECK LIST OF FILES IN AR1 FOR VALIDITY.
;;; SKIPS ON *FAILURE*.
MPFLOK: PUSH P,AR1 ;MUST PRESERVE LH OF AR1
MOVEI AR2A,(AR1)
MPFLO1: JUMPE AR2A,MPFLO2
HLRZ AR1,(AR2A)
JSP T,PRNARK
JRST MPFLO3 ;ERROR
JRST MPFLO3 ;LIST (NOT ALLOWED WITHIN ANOTHER LIST)
SFA$ SKIPA ;NORMAL
SFA$ JFCL ;HANDLED THE SFA
HRRZ AR2A,(AR2A)
JRST MPFLO1
MPFLO3: AOS -1(P) ;ERROR - SKIP
MPFLO2: POP P,AR1
POPJ P,
;;; CHECK OUT OBJECT IN AR1.
;;; SKIP 3 IF AN SFA, AND HANDLED IT
;;; SKIP 2 IF A VALID, OPEN, NON-BINARY, OUTPUT FILE OBJECT.
;;; SKIP 1 IF A LIST (ELEMENTS ARE NOT CHECKED).
;;; SKIP 0 OTHERWISE.
PRNARK: CAIN AR1,TRUTH ;ARG CHECK FOR PRNARG
HRRZ AR1,V%TYO ;FOR T, ASSUME CONTENTS OF TYO
JSP TT,XFOSP ;MUST BE FILE ARRAY OR SFA
JRST PRNRK2
IFN SFA,[
JRST PRNRK1
PUSH P,T ;SAVE T
MOVEI TT,SR.WOM ;AN SFA
HLLZ T,@(F) ;THE APPROPRIATE FUNCTION
TDNN T,@TTSAR(AR1) ;CAN THE SFA DO IT?
JRST PRNRK3 ;NOPE, RESTORE T AND PROCEED
PUSHJ FXP,SAV5 ;SAVE THE 'WORLD'
PUSHJ P,SAVX5
MOVEI C,(A) ;ARGUMENT TO SFA
PUSHJ P,ISTCAL
PUSHJ P,RSTX5
PUSHJ FXP,RST5
POP P,T
JRST 3(T) ;TRIPLE-SKIP RETURN
PRNRK3: POP P,T
JRST 2(T) ;DOUBLE-SKIP RETURN, LOWER-LEVEL WILL HANDLE IT
PRNRK1: ] ;END IFN SFA
MOVE TT,TTSAR(AR1)
TLNE TT,TTS.IO ;MUST BE OUTPUT FILE
TLNE TT,TTS<BN+CL> ;MUST NOT BE CLOSED, NOR BINARY
JRST (T) ;ERROR
JRST 2(T) ;SUCCESS - VALID FILE OBJECT
PRNRK2: MOVEI TT,(AR1)
LSH TT,-SEGLOG
SKIPGE ST(TT)
JRST 1(T) ;OKAY IF LIST (CALLER USUALLY WILL USE MPFLOK)
JRST (T) ;ELSE ERROR
IFN SFA,[
;;; FILE-ARRAY OR LIST IN AR1: IF ZERO USE V%TYO
PRTSTO: PUSH P,PRTSO1 ;IN CASE PRTSTR POPJS
PUSH FXP,F
PUSH FXP,A
MOVEI A,(FXP) ;GIVE IT A PDL NUMBER
JSP F,PRTSTR ;DO SFA CHECKING
[SO.TYO,,]
POP FXP,A
POPI P,1
PRTSO1: POPJ FXP,.+1 ;RETURN TO CALLER
POPI FXP,2 ;HANDLED ALL WE NEEDED TO
POPJ P,
PRTSTR: JUMPE AR1,PRTST1 ;HANDLE DEFAULT CONDITION SPECIALLY
JSP T,PRNARK ;CHECK OUT C(AR1)
JFCL ;PROBABLY BAD OUTFILES
JRST PRTSTL ;A LIST
JRST 1(F) ;A FILE ARRAY OR UNHANDLED SFA
POPJ P, ;A HANDLED SFA
PRTST1: HRRZ AR1,V%TYO
MOVEI TT,SR.WOM ;AN SFA
HLLZ T,@(F) ;THE APPROPRIATE FUNCTION
TDNN T,@TTSAR(AR1) ;CAN THE SFA DO IT?
JRST PRTST2 ;NOPE, RETURN NORMALLY
PUSHJ FXP,SAV5 ;SAVE THE 'WORLD'
PUSHJ P,SAVX5
MOVEI C,(A) ;ARGUMENT TO SFA
PUSHJ P,ISTCAL
PUSHJ P,RSTX5
PUSHJ FXP,RST5
POPJ P, ;RETURN
PRTST2: SETZ AR1, ;MAKE SURE AR1 IS STILL ZERO
JRST 1(F) ;THEN RETURN TO CALLER
PRTSTL: PUSHJ P,MPFLOK ;CHECK THE LIST IN AR1
JRST 1(F) ;RETURN IF ALL OK
PUSHJ P,OFCAN
EXCH A,AR1
PUSHJ P,[IOL [LOSING OUTPUT FILE SPECS!]]
EXCH A,AR1
JRST PRTSTR
] ;END IFN SFA
;TYO$ %TYO %TYO1 TYO $TYO TYOPR TYO1 TYO6 STRTYO TYO6A TYO6B TYO5 TYO2 TYO2A TYO2Z TYO2B TYO4 TYOARG
TYO$: JSP F,PRNAR$ ;USER'S "*TYO" ENTRY
SFA$ [SO.TYO,,QTYO$]
SFA% [QTYO$]
JRST %TYO1
%TYO: JSP F,PRNARG ;USER'S "TYO" ENTRY
SFA% JFCL [Q%TYO]
SFA$ JFCL [SO.TYO,,Q%TYO]
%TYO1: JSP T,GTRDTB
PUSHJ P,TYO1
JRST TRUE
TYO: SKIPE AR1,TAPWRT ;ENTRY FOR SINGLE-ENTER INTERNALS
HRRZ AR1,VOUTFILES ;TEMP ??
SFA$ JSP F,PRTSTO ;DO SFA CHECKING STUFF
$TYO: PUSH FXP,T ;ENTRY FOR PRIN1, PRINC, GC-PRINTOUT,
PUSH FXP,TT ; AND MULTIPLE-ENTER INTERNALS
PUSH P,[PXTTTJ]
JSP T,GTRDTB
TYOPR: SKIPA TT,A ;MUST SAVE R FOR PRINT
TYO1: JSP F,TYOARG
;AT THIS POINT: CHAR IN TT, FILE(S) IN AR1, READTABLE IN AR2A
;MUST SAVE A,B,C,AR1,R
TYO6: .5LKTOPOPJ
STRTYO: JUMPGE AR1,TYO5
TLNN AR1,200000
SKIPE TTYOFF
JRST TYO6A
SKIPLE TYOSW
JRST TYO6A
PUSH P,AR1
HRR AR1,V%TYO
TLZ AR1,600000
PUSHJ P,TYOF
POP P,AR1
TYO6A: MOVEI T,(AR1)
CAIE T,TRUTH
JRST TYO6B
HRR AR1,V%TYO ;T MEANS SAME AS VALUE OF TYO,
SKIPN TTYOFF ; BUT CAN BE SILENCED BY ↑W
TYO6B: SKIPGE TYOSW
POPJ P,
JRST TYOF
TYO5:
REPEAT 2, PUSH P,AR1
HRRZS -1(P)
TLNN AR1,200000
SKIPE TTYOFF
JRST TYO2
HRR AR1,V%TYO
SKIPG TYOSW
PUSHJ P,TYOF
TYO2: SKIPL TYOSW
TYO2A: SKIPN AR1,-1(P)
JRST TYO4
HLRZ AR1,(AR1)
CAIN AR1,TRUTH
JRST TYO2Z
HLL AR1,(P)
JRST TYO2B
TYO2Z: HRRZ AR1,V%TYO
HLL AR1,(P)
SKIPN TTYOFF
TYO2B: PUSHJ P,TYOF
HRRZ AR1,@-1(P)
MOVEM AR1,-1(P)
JRST TYO2A
TYO4: POP P,AR1 ;PRESERVE AR1
JRST POP1J
TYOARG: JSP T,FXNV1
IFN SAIL\ITS, TDNN TT,[777777,,770000] ;UP TO 12. BITS OKAY
IFE SAIL\ITS, TDNN TT,[777777,,777400] ;UP TO 8 BITS OKAY
JRST (F)
JRST TYOAGE
;TYOFA TYOFIL TYOF TYOFS1 TYOFS0 TYOF0D TYOF0E TYOF0G TYOF2 TYOFXL TYOFE
;;; TYO ONE CHARACTER TO ONE FILE. MUST PRESERVE AR1,AR2A
;;; USER INTERRUPTS LOCKED OUT. (??)
;;; FILE ARRAY IN AR1.
;;; READTABLE IN AR2A.
;;; CHARACTER IN TT (MUST BE PRESERVED).
;;; TYOF HANDLES ALL CHARPOS, LINENUM, AND PAGENUM PROCESSING,
;;; CONTROL CHARACTERS, SAIL MODE OUTPUT, ETC.
;;; ALL CR'S NOT FOLLOWED BY LF'S HAVE LF'S SUPPLIED FOR THEM.
;;; MUST SAVE R FOR PRINT.
TYOFA: MOVE TT,A
TYOFIL: .5LKTOPOPJ
TYOF: TRNN AR1,-1
JRST TYOFE
IFN SFA,[
MOVSI T,AS.SFA ;AN SFA?
TDNN T,ASAR(AR1)
JRST TYOFS0 ;NOPE
PUSHJ FXP,SAV5 ;SAVE THE 'WORLD'
PUSHJ P,SAVX5
SKIPGE TT ;DO A CONVERSION ON FORMAT INFO
MOVNI TT,(TT)
JSP T,FXCONS ;CONS UP A FIXNUM
HLLZ T,AR1 ;HAS THIS SFA BEEN HACKED AT A HIGHER LEVEL?
TLZ T,600000 ;BITS NOT OF INTEREST TO THE SFA
MOVEI TT,SR.WOM
TDNE T,@TTSAR(AR1) ;CHECK THE OPERATIONS MASK
JRST TYOFS1 ;ALRADY DONE IT, SO RETURN
HRRZS INHIBI ;REALLY DIDN'T WANT THAT .5LKTOPOPJ
MOVEI C,(A) ;AS THE ARGUMENT TO THE SFA
MOVEI B,Q%TYO ;A TYO OPERATION
MOVEI A,(AR1) ;THE SFA ITSELF
PUSHJ P,ISTCSH ;DO SHORT INTERNAL SFA CALL
TYOFS1: PUSHJ FXP,RST5
JRST RSTX5 ;RESTORE ACS AND RETURN
TYOFS0: ] ;END IFN SFA
MOVE T,TTSAR(AR1)
JUMPL TT,TYOF7 ;NEGATIVE => FORMAT INFO
SKIPGE ATO.LC(T)
PUSHJ P,TYOFXL
IT% CAIN TT,177 ;RUBOUT HAS NO PRINT WIDTH
IT% JRST TYOF4
CAIN TT,7 ;<BELL> HAS NO PRINT WIDTH
JRST TYOF0G
IT$ CAIE TT,177 ;ITS RUBOUT PRINTS AS TWO CHARACTERS
CAIGE TT,40 ;CONTROL CHARACTERS HAVE WIDTH
JRST TYOF2 ; OF 1 OR 2, OR ELSE ARE FUNNY
TYOF0D: AOS D,AT.CHS(T) ;INCREMENT CHARPOS
SKIPE ATO.LC(T) ;SKIP UNLESS LAST CHAR WAS /
JRST TYOF0G
SKIPLE FO.LNL(T) ;ZERO OR NEGATIVE LINEL => INFINITY
TLNE T,TTS<IM> .SEE STERPRI
JRST TYOF0E ;FOR IMAGE OUTPUT, NO EXTRA CHARS
CAMLE D,FO.LNL(T)
SKIPE V%TERPRI
JRST TYOF0E
HRLM TT,(P) ;NEW LINE NEEDED BEFORE THIS CHAR
MOVEI TT,↑M ;BECAUSE OF AUTO-TERPRI
PUSHJ P,TYOF4
PUSHJ P,TYOFXL
MOVEI TT,1
MOVEM TT,AT.CHS(T) ;SO THIS CHAR WILL BE AT CHARPOS 1
HLRZ TT,(P)
TYOF0E: MOVE D,@TTSAR(AR2A) ;GET READTABLE ENTRY FOR THIS
TLNE D,2000 .SEE SYNTAX ;IF THIS IS A /, SET FLAG
HLLOS ATO.LC(T) ; FOR NEXT TIME AROUND
JRST TYOF4
TYOF0G: SETZM ATO.LC(T) ;RESET / FLAG
JRST TYOF4 ;OUTPUT CHAR, IGNORING LINEL
TYOF2: CAIG TT,↑M ;FOUND CONTROL CHAR
CAIGE TT,↑H
JRST TYOF3 ;REGULAR CONTROL CHAR
JRST @.+1-↑H(TT) ;FORMAT EFFECTOR - PECULIAR
TYOFBS ;↑H BACKSPACE
TYOFTB ;↑I TAB
TYOFLF ;↑J LINE FEED
TYOF3 ;↑K <NOT REALLY FORMAT CHAR>
TYOFFF ;↑L FORM FEED
TYOFCR ;↑M CARRIAGE RETURN
TYOFXL: SETZM ATO.LC(T) ;LINE FEED NEEDED BEFORE THIS CHAR
CAIE TT,↑J ;FORGET IT IF THIS CHAR IS LF
TLNE T,TTS<IM> ;DON'T GENERATE LF FOR IMAGE FILE
POPJ P,
HRLM TT,(P)
MOVEI TT,↑J
PUSHJ P,TYOFLF
HLRZ TT,(P)
POPJ P,
TYOFE: EXCH A,AR1
%WTA [SIXBIT \NOT A FILE - TYO!\]
;TYOF3 TYOFBS TYOFTB TYOFLF TYOFFF TYOF7 TYOFCR
TYOF3: CAIN TT,33 ;ALTMODES ARE ALWAYS 1 WIDE
JRST TYOF0D
MOVE D,F.MODE(T) ;RANDOM CONTROL CHAR
IFE SAIL,[
IT$ CAIE TT,177 ;RUBOUT PRINTS TWO POSITIONS EVEN IN SAIL MODE
TLNN D,FBT<SA> ;SKIP IF SAIL MODE FILE
AOS AT.CHS(T) ;OTHERWISE CONTROL CHARS ARE 2 WIDE
] ;END OF IFE SAIL
JRST TYOF0D
TYOFBS: SKIPLE AT.CHS(T) ;BACKSPACE - UNLESS AGAINST LEFT MARGIN,
SOS AT.CHS(T) ; DECREMENT CHARPOS
SETZM ATO.LC(T) ;CLEAR / FLAG
JRST TYOF4
TYOFTB: MOVEI D,7 ;TAB FOUND - JUMP TO NEXT
IORM D,AT.CHS(T) ;MULTIPLE-OF-8 CHARPOS
JRST TYOF0D
TYOFLF: AOS D,AT.LNN(T) ;INCREMENT LINENUM
SKIPLE FO.PGL(T) ;ZERO PAGEL => INFINITY
CAMGE D,FO.PGL(T) ;SKIP IF OVER PAGE LENGTH
JRST TYOF4
TYOFFF: SETZM AT.LNN(T) ;ZERO LINE NUMBER
AOS AT.PGN(T) ;INCREMENT PAGE NUMBER
TLNN T,TTS.TY ;IF TTY THEN DON'T GIVE END PAGE INT ON ↑L
SKIPN FO.EOP(T) ;IF IT HAS AN ENDPAGEFN, THEN
JRST TYOF4 ; WANT TO GIVE USER INTERRUPT
PUSHJ P,TYOF4
MOVEI D,200000+2*FO.EOP+1
HRLI D,(AR1)
JRST UINT
TYOF7: SKIPLE FO.LNL(T) ;INFINITE LINEL
TLNE T,TTS<IM> ; OR IMAGE MODE TTY
POPJ P, ; => IGNORE FORMAT DATA
SKIPN V%TERPRI
SKIPN AT.CHS(T) ;CAN'T DO ANY BETTER THAN TO BE
POPJ P, ; AT THE BEGINNING OF A LINE
MOVEI D,(TT)
ADD D,AT.CHS(T)
CAMG D,FO.LNL(T)
POPJ P,
SETZM AT.CHS(T)
PUSH FXP,TT
MOVEI TT,↑M ;IF TOO LONG, DO AN AUTO-TERPRI
PUSHJ P,TYOFCR
POP FXP,TT
POPJ P,
TYOFCR: SETZM AT.CHS(T) ;CR - SET CHARPOS TO ZERO
PUSHJ P,TYOF4
SETOM ATO.LC(T) ;SET LF FLAG (MUSTN'T DO UNTIL AFTER IOT
POPJ P, ; OF CR BECAUSE A **MORE** MIGHT OCCUR)
;TYOF4 TYOF6 TYOF4A TYOXCT C$ INTTYR TYOF5 TYOF5Y TYOF4C TYOF4J
TYOF4: .SEE PTYO
IT$ TLNE T,TTS.TY
IT$ JRST TYOF4C
TYOF6:
TYOF4A: SKIPL F.MODE(T) .SEE FBT.CM
JRST TYOF5
IFN ITS,[
MOVE D,F.CHAN(T) ;CHARMODE (UNIT MODE)
LSH D,27 ;TYI USES THIS CODE TOO (SAVES F)
IOR D,[.IOT TT]
SPECPRO INTTYX
TYOXCT: XCT D
NOPRO
] ;END OF IFN ITS
IFN D10,[
SA$ OUTCHR TT
IFE SAIL,[
TLNN T,TTS.TY
JRST .+3
IONEOU TT
JRST .+5
CAIE TT,33 ;NON-SAIL MONITORS LOSE ALTMODES
OUTCHR TT
CAIN TT,33 ;FOR THEM, WE OUTPUT ALTMODE AS $
OUTCHR C$ ; (ON THE TTY ONLY!)
] ;END OF IFE SAIL
] ;END OF IFN D10
IFN D20,[
PUSHJ FXP,SAV2
HRRZ 1,F.JFN(T)
MOVEI 2,(TT)
BOUT ;OUTPUT THE BYTE
PUSHJ FXP,RST2
] ;END OF IFN D20
AOS F.FPOS(T) ;ADJUST FILE POSITION (DOESN'T HURT IF F.FLEN NEG)
C$: POPJ P,"$
INTTYR: HRROS INHIBIT .SEE $IWAIT ;COME HERE AFTER INTERRUPT
MOVE T,TTSAR(AR1) ;FILE ARRAY MAY HAVE MOVED
POPJ P, .SEE TYIXCT TYICAL
TYOF5: ;BLOCK MODE
IFN ITS+D20,[
IDPB TT,FB.BP(T) ;PUT BYTE IN BUFFER
SOSLE FB.CNT(T) ;DECREMENT COUNT
] ;END OF IFN ITS+D20
IFN D10,[
MOVE D,FB.HED(T) ;FOR D10, BYTE POINTER AND COUNT ARE IN BUFFER HEADER
IDPB TT,1(D) ;PUT BYTE IN BUFFER
SOSLE 2(D) ;DECREMENT COUNT
] ;END OF IFN D10
POPJ P,
HRLM TT,(P)
MOVE TT,T
PUSH FXP,F
PUSHJ P,IFORCE
POP FXP,F
HLRZ TT,(P)
TYOF5Y: MOVE T,TTSAR(AR1)
POPJ P,
IFN ITS,[
TYOF4C: TLNN T,TTS.IM ;DO NOT HACK THIS FOR IMAGE MODE
CAIE TT,↑P ;↑P IS THE DISPLAY ESCAPE CODE, AND
JRST TYOF4A ; MUST BE TREATED SPECIALLY
SKIPGE F.MODE(T) .SEE FBT.CM
JRST TYOF4J
MOVE TT,FB.CNT(T) ;FOR BLOCK MODE, BE CAREFUL
PUSH FXP,F
CAIGE T,2 ; ABOUT SPLITTING A ↑P-CODE
PUSHJ P,IFORCE ; ACROSS A BLOCK BOUNDARY
POP FXP,F
TYOF4J: MOVE T,TTSAR(AR1) ;OUTPUT ↑P AS ↑P P
MOVEI TT,↑P
PUSHJ P,TYOF4A
MOVE T,TTSAR(AR1)
MOVEI TT,"P
PUSHJ P,TYOF4A
JRST TYOF5Y
] ;END OF IFN ITS
;%TERPRI TRP$ TERPRI TERP1 ITERPRI PTYO PTYO1 PTYO3 PTYO2
SUBTTL TERPRI AND PTYO FUNCTIONS
%TERPRI:
JUMPN T,.+3
PUSH P,R70
MOVNI T,1
PUSH P,(P) ;EVEN THOUGH LSUBR (0 . 1)
SOS T ;PRETEND TO BE (1 . 2) FOR PRNARG'S SAKE
JSP F,PRNARG ;PRNARG MAY DO A POPJ FOR US - BEWARE!
SFA% 400000,,[Q%TERPRI] ;BIT 4.9 => RETURN VALUE IS NIL
SFA$ 400000,,[SO.TRP,,Q%TERPRI] ;BIT 4.9 => RETURN VALUE IS NIL
JRST TERP1
TRP$: JSP F,PRNAR$
SFA% 400000,,[QTRP$]
SFA$ 400000,,[SO.TRP,,QTRP$]
JRST TERP1
TERPRI: SKIPE AR1,TAPWRT ;1/4-INTERNAL TERPRI
HRRZ AR1,VOUTFILES
SFA$ JSP F,PRTSTR ;DO SFA CHECKING STUFF
SFA$ [SO.TRP,,]
TERP1: JSP T,GTRDTB ;SEMI-INTERNAL TERPRI
MOVEI A,NIL
ITERPRI:
PUSH P,A ;INTERNAL TERPRI - SAVES A,B,C
MOVEI TT,↑M ;MUST HAVE FILE ARRAY IN AR1,
PUSHJ P,TYO6 ; READTABLE IN AR2A
MOVEI TT,↑J
PUSHJ P,TYO6
JRST POPAJ
PTYO: SKIPE V.RSET ; +TYO: SUBR 2
JRST PTYO2
PTYO1: MOVE TT,(A) ;FIRST ARG IS ASCII VALUE
CAIN B,TRUTH ;IF T
MOVE B,V%TYO
IFN SFA,[
MOVSI T,AS.SFA ;CHECK IF AN SFA
TDNE T,ASAR(B) ;SFA BIT SET IN ASAR?
JRST PTYO3 ;YUP, CALL AS AN SFA
] ;END IFN SFA
.5LKTOPOPJ
MOVE T,TTSAR(B) ;SECOND ARG IS FILE
MOVEI A,TRUTH ;RETURNS T
JRST TYOF4
IFN SFA,[
PTYO3: MOVEI C,(A) ;THIRD ARG IS THE FIXNUM
MOVEI A,(B) ;FIRST ARG IS SFA ITSELF
MOVEI B,Q%TYO ;TYO OPERATION
JRST ISTCSH ;DO FAST INTERNAL CALL
] ;END IFN SFA
PTYO2:
IFN SFA,[
JSP TT,AFOSP ;CHECK FOR AN SFA
JFCL
SKIPA ;NOPE
JRST PTYO3 ;YUP, SO CALL IT
] ;END IFN SFA
JSP T,FXNV1
MOVEI AR1,(B)
PUSHJ P,ATOFOK
UNLOCKI ;MARGINAL DANGER THAT FILE COULD
JRST PTYO1 ; GET SCEWED BY INTERRUPT HERE
;PRINT %PRINT $PRINT CTY1 CTY2 PRIN1B PRIN1 %PRIN1 %PR1 $PRIN1 %PR1A PRINC %PRINC %PRC $PRINC X X
SUBTTL PRINT, PRIN1, PRINC
PRINT: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRINT
MOVE AR1,VOUTFILES
SFA$ JSP F,PRTSTR ;DO SFA CHECKING STUFF
SFA$ [SO.PRT,,]
JRST $PRINT
%PRINT: JSP F,PRNARG ;LSUBR (1 . 2)
SFA% JFCL [Q%PRINT]
SFA$ JFCL [SO.PRT,,Q%PRINT]
$PRINT: JSP T,GTRDTB ;AR1 SHOULD BE SET UP BEFORE COMING HERE
PUSHJ P,ITERPRI
CTY1: PUSHJ P,$PRIN1
CTY2: %SPC%
POPJ P,
PRIN1B: MOVE A,B
PRIN1: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRIN1
MOVE AR1,VOUTFILES
SFA$ JSP F,PRTSTR
SFA$ [SO.PR1,,]
JRST $PRIN1
%PRIN1:
%PR1: JSP F,PRNARG ;LSUBR (1 . 2)
SFA% JFCL [Q%PR1]
SFA$ JFCL [SO.PR1,,Q%PR1]
$PRIN1: MOVE R,[PR.ATR,,$TYO] ;AR1 SHOULD BE SET UP BEFORE COMING HERE
%PR1A: JSP T,GTRDTB
PUSHJ P,PRINTY
JRST TRUE
PRINC: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRINC
MOVE AR1,VOUTFILES
SFA$ JSP F,PRTSTR
SFA$ [SO.PRC,,]
JRST $PRINC
%PRINC:
%PRC: JSP F,PRNARG ;LSUBR (1 . 2)
SFA% JFCL [Q%PRC]
SFA$ JFCL [SO.PRC,,Q%PRC]
$PRINC: MOVE R,[PR.PRC,,$TYO] ;AR1 SHOULD BE SET UP BEFORE COMING HERE
JRST %PR1A
;;; SUBR VERSIONS - *PRINT, *PRIN1, *PRINC
IFE SFA,[
IRPS X,,[PRT$:PR1$:PRC$:]Y,,[$PRINT,$PRIN1,$PRINC]
X: JSP F,PRNAR$
[Q!X]
JRST Y
TERMIN
] ;END IFE SFA
IFN SFA,[
IRPS X,,[PRT$:PR1$:PRC$:]Y,,[$PRINT,$PRIN1,$PRINC]Z,,[SO.PRT,SO.PR1,SO.PRC]
X: JSP F,PRNAR$
[Z,,Q!X]
JRST Y
TERMIN
] ;END IFN SFA
;PR.PRC PR.ATR PR.NUM PR.NVB PR.EFC PR.NLS PRINTY PRINTF PRINTA PRINT3 PRINT4 PRINH6 PRIN7A PRIN8A
SUBTTL MAIN PRINTOUT ROUTINE
;;; ***** OKAY, OUTPUT LOVERS, HERE'S YOUR MAIN PRINT ROUTINE *****
;;; CALLED WITH OBJECT TO PRINT IN A, ADDRESS OF "TYO" ROUTINE IN R.
;;; CLOBBERS A (RETURNS GARBAGE); TO SAVE A OVER PRINTY, USE APRINT.
;;; VARIOUS BITS ARE KEPT IN THE LEFT HALF OF R.
;;; SOME ARE PASSED IN, AND OTHERS ARE INITIALIZED AND USED INTERNALLY.
PR.PRC==400000 ;MUST BE SIGN BIT! 0 => PRIN1, 1 => PRINC. (PASSED IN)
PR.ATR==200000 ;1 => DO AUTO-TERPRI HACKS
PR.NUM==4000 ;SYMBOL LOOKS LIKE A NUMBER SO FAR
PR.NVB==2000 ;NOT PROVEN YET THAT VERTICAL BAR NEEDED
PR.EFC==1000 ;EMBEDDED FUNNY CHARACTER IN SYMBOL FLAG (1 => NONE SEEN)
PR.NLS==400 ;NOT PROVEN YET THAT LEADING SLASH NEEDED
;;; PRINTA EXPECTS B,C,T,TT,R SAFE OVER THE "TYO" ROUTINE.
;;; THE "TYO" ROUTINE GENERALLY EXPECTS AR1 AND AR2A SAFE OVER PRINTA.
;;; USES DIRECTLY OR INDIRECTLY A,B,C,T,TT,D,R,F.
;;; IN THE USELESS VERSION OF LISP, THERE ARE ABBREVIATION HACKS:
;;; PRINTY IS THE ENTRY FOR PRIN1/PRINC; ABBREVIATION IS CONTROLLED
;;; BY BIT 1.1 OF (STATUS ABBREVIATE). TYOSW INDICATES WHETHER
;;; A CHAR IS MEANT FOR TTY, FILES, OR BOTH (IN THIS WAY THE TTY
;;; CAN RECEIVE ABBREVIATIONS WHILE FILES RECEIVE FULL S-EXPRS).
;;; PRINTF IS THE ENTRY FOR FLATSIZE/EXPLODE; ABBREVIATION IS
;;; CONTROLLED BY BIT 1.2 OF (STATUS ABBREVIATE).
;;; PRINTA IS THE ENTRY FOR ALL OTHER PRINT HACKERS; IT
;;; NEVER ABBREVIATES.
IFE USELESS,[
PRINTY: SKIPE V%TERPRI ;TERPRI NON-NIL => NEVER AUTO-TERPRI
PRINTF: ;ENTRY FOR FLATSIZE/EXPLODE
PRINTA: TLZ R,PR.ATR ;OTHER GUYS DON'T WANT AUTO-TERPRI HACKS
PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING
ROT A,-SEGLOG ;NOTE THAT A IS SAFE ON PDL
SKIPL TT,ST(A) ;MUST DO A ROT, NOT LSH! SEE PRINX
JRST PRINX
%LPAR% ;PRINT A LIST. FIRST TYO A (
PRINT4: HLRZ A,@(P)
IFN HNKLOG,[
TLNE TT,HNK
JRST PRINH0
PRINH6:
] ;END OF IFN HNKLOG
PUSHJ P,PRINT3 ;NOW PRINT CAR OF THE LIST
HRRZ A,@(P)
JUMPE A,PRIN8A ;IF CDR IS NIL, NEED ONLY A )
PRIN7A: MOVEM A,(P)
%SPC% ;ELSE SPACE IN BETWEEN
LSH A,-SEGLOG ;WE KNOW A IS NON-NIL!
SKIPGE TT,ST(A)
JRST PRINT4 ;IF CDR IS NON-ATOMIC, LOOP
%DOT% ;ELSE DOTTED LIST
%SPC%
PUSHJ P,PRIN1A ;SO PRINT THE ATOM AFTER THE LISP DOT
PRIN8A: %RPAR% ;NOW TYO A )
JRST POP1J
] ;END OF IFE USELESS
;PRINTY PRINTF APRINT PRINTA PRINT0 PRIN0A PRINT1 PRIN1Q PRINT2
IFN USELESS,[
PRINTY: MOVEI D,PRINT1 ;ENTRY FOR PRIN1/PRINC
SKIPE V%TERPRI
TLZ R,PR.ATR ;TERPRI NON-NIL => NEVER AUTO-TERPRI
JRST PRINT0
PRINTF: MOVEI D,PRINT2 ;ENTRY FOR FLATSIZE/EXPLODE
TLZ R,PR.ATR
JRST PRINT0
APRINT: PUSH P,A
PUSH P,CPOPAJ
PRINTA: MOVEI D,PRIN3A ;ENTRY FOR NO ABBREVIATIONS
TLZ R,PR.ATR
PRINT0: PUSH P,A ;CLOBBERS ARG (RETURNS GARBAGE)
SKIPN V.RSET ;IF IN *RSET MODE, CHECK VALUES OF
JRST PRIN0A ; PRINLEVEL AND PRINLENGTH
IRP X,,[%LEVEL,%LENGTH]Y,,[%LV,%LN]
Y!CHK: SKIPN A,V!X ;NIL IS A VALID VALUE
JRST PRT!Y
SKOTT A,FX
JRST Y!ERR
SKIPGE (A)
JRST Y!ERR
PRT!Y:
TERMIN
PRIN0A: SETOM PRINLV ;PRINLV HAS <ACTUAL PRINT LEVEL>-1
SETZM ABBRSW ;ASSUME ABBRSW ZERO
JSP T,RSXST
MOVEI A,LRCT-2 ;GET (STATUS ABBREVIATE)
NW% HRRZ T,@RSXTB
NW$ LDB T,[001120,,RSXTB] ;PICK UP CHTRAN
HRRZ A,(P) ;MUST LEAVE ARG IN A FOR PRINT3
SETZM PRPRCT
JRST (D) ;DISPATCH TO PRINT1, PRINT2, PRINT3
PRINT1: SETOM ABBRSW ;PRIN1/PRINC
SKIPE TAPWRT ;OPEN FILES? WHETHER OR NOT TO ABBREVIATE THEM
JRST PRIN1Q
SKIPN TTYOFF ;IF NO FILES OPEN, THEN ABBREVIATE FOR TTY
JRST PRIN3A
PRIN1Q: TRNN T,1 ;ULTIMATE DECISION ON FILE ABBREVIATION
HRRZS ABBRSW ; COMES FROM (STATUS ABBREVIATE)
JRST PRIN3A
PRINT2: TRNE T,2 ;FLATSIZE/EXPLODE - DECIDE WHETHER IT
SETOM ABBRSW ; WANTS ABBREVIATION OR NOT
JRST PRIN3A
;PRINT3 PRIN3A PRIN3F PRINT4 PRINT5 PRINT6 PRINT7 PRINH6 PRIN7A PRINT8 PRIN8A PRINT9
PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING
PRIN3A: ROT A,-SEGLOG ;NOT LSH! SEE PRINX
SKIPL TT,ST(A)
JRST PRINX ;IF SO, USE AN ATOM PRINTER
MOVE T,TYOSW ;SAVE OLD VALUE OF TYOSW
HRLM T,-1(P) ; (I.E. THAT OF PREVIOUS LEVEL)
JUMPN T,PRINT4 ;IF PREVIOUS LEVEL WAS NON-ABBREV,
SKIPN ABBRSW ; OR IF WE DON'T EVER WANT ABBREV,
JRST PRINT4 ; THEN NEEDN'T TRY TO ABBREV!
AOS T,PRINLV ;ELSE INCREMENT LEVEL COUNT
SKIPE V%LEVEL ;IF PRINLEVEL=NIL, OR IF ACTUAL LEVEL
CAMGE T,@V%LEVEL ; IS LESS, THEN DON'T ABBREV
JRST PRINT4
SKIPL ABBRSW
SETOM TYOSW
CAME T,@V%LEVEL ;IF WE'RE EXACTLY EQUAL TO PRINLEVEL,
JRST PRIN3F
MOVEI T,1
PUSHJ P,PRINLP
%NMBR% ; SHOOT OUT LEVEL ABBREVIATION
PRIN3F: SKIPGE ABBRSW ;IF WE ONLY WANT ABBREVIATION,
JRST PRINT9 ; NEEDN'T GROVEL OVER THE SUBLIST
HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE
PRINT4: PUSH FXP,PRPRCT ;SAVE PARENS COUNTS
HLLOS PRPRCT ;CLEAR RIGHT PARENS COUNT, AND
AOS PRPRCT ; INCREMENT LEFT PARENS COUNT
PUSH FXP,XC-1 ;<ACTUAL PRINT LENGTH>-1 FOR THIS LEVEL
MOVE T,TYOSW ;SAVE CURRENT TYOSW (DETERMINES WHETHER
HRLM T,(P) ; ABBREV MODE OUTPUT WANTS A ) AT END)
PRINT5: SKIPN TYOSW ;IF WE ARE IN NON-ABBREV ONLY MODE,
SKIPN ABBRSW ; OR IF WE NEVER WANT ABBREV,
JRST PRINT7 ; THEN DON'T TRY TO ABBREV!
AOS T,(FXP) ;ELSE INCREMENT PRINT LENGTH
SKIPE V%LENGTH ;IF PRINLENGTH=NIL, OR IF WE'RE LESS
CAMGE T,@V%LENGTH ; THAN IT, THEN DON'T ABBREV
JRST PRINT7
SKIPL ABBRSW
SETOM TYOSW
CAME T,@V%LENGTH
JRST PRINT6 ;IF WE'RE EXACTLY EQUAL, THEN ABBREV
MOVEI T,3
PUSHJ P,PRINLP
REPEAT 3, %DOT%
PRINT6: SKIPGE ABBRSW ;IF WE DON'T WANT NON-ABBREV ONLY MODE,
JRST PRINT8 ; THEN CAN IGNORE REST OF LIST
HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE
PRINT7: HRRZ A,(P)
HRRZ B,(A)
HLRZ A,(A)
HRRZ T,-1(FXP)
ADDI T,1
SKIPN B
HRRM T,PRPRCT
IFN HNKLOG,[
TLNE TT,HNK
JRST PRINH0
PRINH6:
] ;END OF IFN HNKLOG
PUSHJ P,PRINT3 ;SO PRINT THE CAR OF THE LIST
SETZM PRPRCT
HRRZ A,(P)
HRRZ A,(A)
JUMPE A,PRINT8 ;IF CDR IS NIL, NEED ONLY A ) NOW
PRIN7A: HRRM A,(P)
%SPC% ;ELSE SPACE BETWEEN
LSH A,-SEGLOG
SKIPGE TT,ST(A)
JRST PRINT5 ;IF CDR NON-ATOMIC, THEN LOOP
%DOT% ;ELSE WE HAVE A DOTTED LIST
%SPC%
HRRZ T,-1(FXP)
ADDI T,1
MOVEM T,PRPRCT
PUSHJ P,PRIN1A ;PRINT THE ATOM AFTER THE LISP DOT
PRINT8: HLRZ T,(P) ;THIS WILL TELL TYO WHAT TO
MOVEM T,TYOSW ; DO WITH THE )
PRIN8A: SUB FXP,R70+1
POP FXP,PRPRCT
%RPAR% ;TYO A ) TO END THE LIST
PRINT9: HLRZ T,-1(P) ;RESTORE TYOSW TO WHAT IT WAS
MOVEM T,TYOSW ; ON LAST (RECURSIVE!) ENTRY
JUMPN T,POP1J ;IF AND ONLY IF WE AOS'ED PRINLV,
SKIPE ABBRSW ; WE MUST NOW SOS IT, AND THEN POP1J
SOS PRINLV
JRST POP1J
] ;END OF IFN USELESS
;PRINH0 PRINH2 PRHN2B PRINH3 PRHN3A PRHN3B
SUBTTL PRINT A HUNK
IFN HNKLOG,[
PRINH0: SKIPN VHUNKP ;IF HUNKP IS NIL, THEN PRINT A HUNK
JRST PRINH6 ; AS IF IT WERE A LIST CELL
MOVEI T,(TT)
CAIN T,QHUNK0
CAIE A,-1
JRST .+2
JRST PRHN3B
PUSH FXP,T
PUSHJ P,PRINT3 ;PRINT FIRST ELT
IFN USELESS, SETZM PRPRCT
POP FXP,TT
MOVSI T,-1
2DIF [LSH T,(TT)]0,QHUNK0
HRR T,(P)
ADD T,R70+1
JUMPGE T,PRHN3A ;"HUNK2" CASE, WITH 2 ELEMENTS
PUSH P,T
PRINH2: MOVEM T,(P)
PRHN2B: HRRZ A,(P)
HRRZ A,(A)
CAIN A,-1
JRST PRINH3
%SPC%
%DOT%
%SPC%
PUSHJ P,PRINT3
HRRZ A,(P)
HLRZ A,(A)
CAIN A,-1
JRST PRINH3
%SPC%
%DOT%
%SPC%
PUSHJ P,PRINT3
MOVE T,(P)
AOBJN T,PRINH2
PRINH3: SUB P,R70+1 ;FINISHED WITH HUNK (EXCEPT FOR CDR)
PRHN3A: %SPC%
%DOT%
%SPC%
PRHN3B: HRRZ A,(P)
HRRZ A,(A)
PUSHJ P,PRINT3
%SPC%
%DOT%
JRST PRIN8A
] ;END OF IFN HNKLOG
;PRINX PRIN1A PRIN1Z PRINA1 PRINA2 PRINA3 PRINA4 PRINX5 PRINL4
SUBTTL PRINT ATOM DISPATCH, AND PRINT AN ARRAY OR A RANDOM
PRINX: PUSH P,CPOP1J ;PRINT AN ATOM (ON THE PDL)
PRIN1A: ;TT HAS ST ENTRY
HRRZ A,-1(P) ;NIL IS SYMBOL, NOT RANDOM!!!
JUMPE A,PRINIL
2DIF JRST (TT),.,QLIST .SEE STDISP ;TT MUST HAVE ST ENTRY
PRIN1Z: JRST PRINI ;FIXNUM
JRST PRINO ;FLONUM
DB$ JRST PRINDB ;DOUBLE
CX$ JRST PRINCX ;COMPLEX
DX$ JRST PRINDX ;DUPLEX
BG$ JRST PRINB ;BIGNUM
JRST PRINN ;SYMBOL
HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS
JFCL ;RANDOM
IFN .-PRIN1Z-NTYPES+2, WARN [WRONG LENGTH TABLE]
IFN USELESS,[
MOVEI T,25.
PUSHJ P,PRINLP
SETZM PRPRCT
] ;END OF IFN USELESS
%NMBR% ;ARRAY (AND RANDOM)
TLNN TT,SA
JRST PRINX5
HRRZ A,-1(P)
MOVE TT,ASAR(A)
CAIE TT,ADEAD
JRST PRINA2
SKIPA TT,[440700,,[ASCIZ \DEAD-ARRAY\]]
PRINA1: PUSHJ P,(R)
ILDB A,TT
JUMPN A,PRINA1
POPJ P,
PRINA2: TLNE TT,AS<FIL>
JRST PRNFL
TLNE TT,AS<JOB>
JRST PRNJB
SFA$ TLNE TT,AS.SFA ;SFA?
SFA$ JRST PRNSR
JFFO TT,.+1
HRRZ A,ARYTYP(D)
TLC TT,AS<SX> ;CROCK FOR NSTORE ARRAYS
TLNN TT,AS<SX+GCP>
SETZ A,
PUSHJ P,PRINSY
%NEG%
HRRZ A,-1(P)
LDB F,[TTSDIM,,TTSAR(A)]
PRINA3: HRRZ A,-1(P)
MOVNI TT,(F)
MOVE TT,@TTSAR(A)
IFE USELESS, MOVE C,@VBASE ;BETTER BE A FIXNUM!
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
SOJE F,PRINA4
%CLN%
JRST PRINA3
PRINA4: %NEG%
PRINX5: HRRZ TT,-1(P)
PRINL4: MOVEI C,10 ;N BASE 8
JRST PRINI3
;PRNSR PRNJB PRNFL PRNF5 PRNF6 PRNJ2 PRNF1 PRNSTO PRNJ1 PRNSR1
SUBTTL PRINT A FILE OBJECT, PRINT A JOB OBJECT, PRINT AN SFA
;;; PRINT A JOB OBJECT AS #JOB-|<NAME>|-<ADDRESS>
;;; PRINT A FILE OBJECT AS #FILE-<DIR>-|<NAME>|-<ADDRESS>
;;; PRINT AN SFA AS #SFA-|<SFA-PRINTNAME>|-<ADDRESS>
;;; WHERE <DIR> IS "IN" OR "OUT", <NAME> IS THE TRUENAME,
;;; <SFA-PRINTNAME> IS THE THING GIVEN AS THE THIRD ARG TO CREATE-SFA
;;; AND <ADDRESS> IS THE OCTAL ADDRESS OF THE SAR.
IFN SFA,[
PRNSR: MOVEI T,[ASCIZ \SFA-\]
JRST PRNF5
] ;END IFN SFA
PRNJB: MOVEI T,[ASCIZ \JOB-\]
JRST PRNF5
PRNFL: MOVEI T,[ASCIZ \FILE-\]
PRNF5: PUSHJ P,PRNSTO
HRRZ A,-1(P)
MOVE TT,ASAR(A)
SFA$ TLNE TT,AS.SFA ;SFA?
SFA$ JRST PRNSR1 ;YES, PRINT DIFFERENTLY
PUSH FXP,TT
TLNE TT,AS.JOB ;DON'T PRINT DIR FOR JOB ARRAY
JRST PRNF6
MOVE TT,TTSAR(A)
;FORMERLY, THIS ROUTINE USED PRINSY TO PRINT IN OR OUT. BUT, SINCE THIS
;ROUTINE CAN BE CALLED FROM THE GARBAGE COLLECTOR, THE POINTERS COULD BE
;MARKED AND THEREFORE INVALID. TO AVOID PRINTING LOSSAGE, PRINTING IS DONE
;MANUALLY.
MOVEI T,[ASCII \IN\] ;ASSUME INPUT FILE
TLNE TT,TTS<IO>
MOVEI T,[ASCII \OUT\]
PUSHJ P,PRNSTO
%NEG%
PRNF6: %VBAR%
POP FXP,T ;SAVED ASAR
MOVNI TT,LPNBUF
PUSH FXP,PNBUF+LPNBUF(TT) ;UNFORTUNATELY, SOMEONE MIGHT BE USING
AOJL TT,.-1 ; PNBUF, SO WE MUST SAVE IT
HRRZ A,-1(P)
PUSH FXP,R
20$ MOVE TT,TTSAR(A) ;FOR D20 CLOSED FILE NEEDS SPECIAL HANDLING
20$ TLNN TT,TTS.CL ;CLOSED? (ASAR SAVED IN T)
TLNE T,AS.JOB ;DON'T GET TRUENAME FOR JOB ARRRAYS
JRST PRNJ1
PUSHJ P,TRU6BT ;GET TRUENAME OF FILE ON FXP
PRNJ2: PUSHJ P,6BTNSL ;CONVERT THAT TO A NAMESTRING IN PNBUF
POP FXP,R
MOVEI TT,-LPNBUF+1(FXP)
MOVSI T,-LPNBUF
PRNF1: MOVE D,PNBUF(T) ;SWAP PNBUF WITH COPY ON PDL
EXCH D,(TT)
MOVEM D,PNBUF(T)
ADDI TT,1
AOBJN T,PRNF1
MOVEI T,-LPNBUF+1(FXP)
PUSHN FXP,1 ;BE SURE STRING ENDS WITH ZEROS
PUSHJ P,PRNSTO
POPI FXP,LPNBUF+1 ;POP THE CRUD
%VBAR%
JRST PRINA4
PRNSTO: HRLI T,440700
ILDB A,T
JUMPE A,CPOPJ
PUSHJ P,(R)
JRST .-3
PRNJ1: HRRZ TT,TTSAR(A)
HRLI TT,-L.F6BT
20% PUSH FXP,F.RDEV(TT)
20$ PUSH FXP,F.DEV(TT)
AOBJN TT,.-1
JRST PRNJ2
IFN SFA,[
PRNSR1: %VBAR%
MOVEI TT,SR.PNA ;GET THE PNAME
HRRZ A,-1(P) ;PICK UP ARRAY POINTER
HRRZ A,@TTSAR(A)
PUSH FXP,R ;REMEMBER R OVER RECURSIVE CALL TO PRINT
TLO R,PR.PRC
PUSHJ P,PRINTA ;PRINT THE NAME
POP FXP,R
%VBAR%
JRST PRINA4
] ;END IFN SFA
;PRINSY PRINN PRINIL PRNN1 PRNN2A PRNN2B PRNN2C PRNN2 PRNN3 PRNN3A PRNN3B PRNN3C
SUBTTL PRINT AN ATOMIC SYMBOL
;PRINIL:
;IFN USELESS, PUSHJ P,PLP1
; MOVEI A,"( ;PRINT () FOR NIL
; PUSHJ P,(R)
; MOVEI A,")
; JRST (R)
PRINSY: PUSH P,A
PUSH P,CPOP1J
JUMPE A,PRINIL
PRINN: SKIPA A,-1(P)
PRINIL: MOVEI A,[$$$NIL,,]
JSP C,MAPNAME
JUMPGE R,PRNN2 .SEE PR.PRC
IFN USELESS, PUSHJ P,PLP1
PRNN1: JSP C,(C) ;FOR PRINC, JUST OUTPUT THE CHARS
POPJ P,
MOVEI A,(TT)
PUSHJ P,(R)
JRST PRNN1
PRNN2A:
IFN USELESS,[
HLRZ T,PRPRCT
PRNN2B: SOJL T,PRNN2C
%LPAR%
JRST PRNN2B
PRNN2C: HRRZS PRPRCT
] ;END OF IFN USELESS
%VBAR% ;FOR NULL PNAME, PRINT ||
%VBAR%
JRST PLP1
PRNN2: JSP C,(C) ;GET FIRST CHAR
JRST PRNN2A ;FOR NULL PNAME, JUST PRINT HANGING LEFT PARENS
TLO R,PR.NVB+PR.NUM+PR.EFC+PR.NLS
SETZ F, ;F COUNTS: <# SLASHES,,# CHARS>
HRRZ A,VREADTABLE
MOVE D,@TTSAR(A)
TLNN D,14 ;IF NOT A DIGIT OR A SIGN,
TLZ R,PR.NUM ; THEN IT ISN'T NUMBER-LIKE
TLNN D,400 ;IF NOT SLASHIFIED AS FIRST CHAR,
AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER
TLZ R,PR.EFC ;ELSE ONE FUNNY CHAR SEEN ALREADY
TLNE D,171000 ;REAL WEIRDIES FORCE VERTICAL BARS
TLZ R,PR.NVB
PRNN3: ADD F,R70+1 ;BUMP CHAR COUNT AND SLASH COUNT
PRNN3A: JSP C,(C) ;GET NEXT CHAR
JRST PRNN4
MOVE D,@TTSAR(A)
TLNN D,24 ;IF IT LOOKS LIKE A NUMBER SO FAR
TLZN R,PR.NUM ; BUT THIS NEXT CHAR ISN'T DIGIT OR ARROW,
JRST PRNN3B
TRNE F,777770 ; THEN WE NEED A LEADING SLASH IF THERE WERE
TLZ R,PR.NLS ; MORE THAN SEVEN LEADING NUMBER-LIKE CHARS
PRNN3B: TLNN D,100 ;IF NOT SLASHIBLE IN FIRST POSITION,
PRNN3C: AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER
TLNN D,2000 ;VERTICAL BARS CAN'T HELP A SLASH
CAIN TT,"| ; OR VERTICAL BAR, SO COUNT THEM AS
AOJA F,PRNN3C ; TWO CHARACTERS AND NO SLASHES
TLNN D,171000 ;REAL WEIRDIES
TLZN R,PR.EFC ; OR TWO EMBEDDED FUNNY CHARS
TLZ R,PR.NVB ; FORCE VERTICAL BARS
JRST PRNN3
;PRNN4 PRNN4A PRNN4B PRNN5 PRNN5A VBARPOPJ PRNN6 PRNN6A
PRNN4: CAIN F,1 ;A SIGN WITH NO FOLLOWING
TLNN D,10 ; DIGITS DOESN'T NEED A SLASH
CAIA
JRST PRNN4A
TLNE R,PR.NUM ;IF THE WHOLE THING IS NUMBER-LIKE,
TLZ R,PR.NLS ; THEN DEFINITELY NEED A LEADING SLASH
PRNN4A: MOVEI T,2(F)
TLNN R,PR.NVB
JRST PRNN4B
HLRZ T,F ;WE AREN'T USING VERTICAL BARS
ADDI T,1(F) ; SO MUST COMPUTE UP ROOM TAKEN BY
TLNN R,PR.NLS ; CHARS AND SLASHES, PLUS ONE FOR THE SPACE
ADDI T,1 ; WHICH MAY FOLLOW
PRNN4B: PUSHJ P,PRINLP
SKIPN A,-1(P)
MOVEI A,[$$$NIL,,]
JSP C,MAPNAME
TLNE R,PR.NVB
JRST PRNN6
%VBAR% ;DO THE VERTICAL BAR THING
PRNN5: JSP C,(C)
JRST VBARPOPJ
CAIE TT,↑M
CAIN TT,"|
JRST PRNN5A
MOVE A,VREADTABLE
MOVE D,@TTSAR(A)
TLNE D,2000
PRNN5A: %SLSH%
MOVEI A,(TT)
PUSHJ P,(R)
JRST PRNN5
VBARPOPJ: %VBAR%
POPJ P,
PRNN6: MOVEI F,400
PRNN6A: JSP C,(C)
POPJ P,
20$ PUSH P,B ;B MUST BE PRESERVED
MOVE A,VREADTABLE
MOVE D,@TTSAR(A)
TLOE R,PR.NLS
TLNE D,(F)
%SLSH%
MOVEI A,(TT)
PUSHJ P,(R)
20$ POP P,B
MOVEI F,100
JRST PRNN6A
;MAPNAME MAPNM1 MAPNM2 MAPNM3 PRINLP PLP1 PRINLQ
;;; COROUTINE TO DELIVER UP CHARACTERS OF A PRINT NAME.
;;; USES JSP C,(C) TO CALL. USES B, T; YIELDS CHARS IN TT.
;;; SETUP USES A. SKIPS UNLESS NO MORE CHARS.
MAPNAME:
HLRZ B,(A)
HRRZ B,1(B)
JSP C,(C)
MAPNM1: HLRZ T,(B)
MOVE T,(T)
TRZ T,1 ;FORCE OFF LOW ORDER BIT, IS UNUSED IN ASCII
MAPNM2: SETZ TT,
ROTC T,7
SKIPN T ;ONLY CHECK FOR NULLS IF AT THE END OF THE WORD
JUMPE TT,MAPNM3
JSP C,1(C)
JRST MAPNM2
MAPNM3: HRRZ B,(B)
JUMPN B,MAPNM1
JRST (C)
;;; ROUTINE TO FEED FORMATTING INFORMATION TO TYO IF DESIRED,
;;; THEN PRINT ANY PENDING LEFT PARENTHESES.
;;; THE LENGTH OF THE ATOM TO BE PRINTED IS IN T.
;;; USES ONLY A AND T.
PRINLP: TLNN R,PR.ATR
JRST PLP1
IFN USELESS,[
MOVSI T,(T)
ADD T,PRPRCT
HLRZ T,T
ADD T,PRPRCT
] ;END OF IFN USELESS
TRNE T,777000
MOVEI T,777
HRROI A,1(T) ;ALLOW FOR FOLLOWING SPACE
PUSHJ P,(R)
PLP1: .SEE PRNN1
IFE USELESS, POPJ P,
IFN USELESS,[
HLRZ T,PRPRCT
PRINLQ: SOJL T,CPOPJ
%LPAR%
JRST PRINLQ
] ;END OF IFN USELESS
;PRINI PRI2D PRI2C PRI2Q PRI2A PRINI2 PRINI9 PRINI3 FP7A1 FP7B PRINI5 PRINI7 PRI.
SUBTTL PRINT A FIXNUM
PRINI: MOVE A,VBASE
IFN USELESS, CAIN A,QROMAN
IFN USELESS, JRST PRINRM
SKOTT A,FX
JRST BASER
MOVE C,(A) ;TRUE VALUE OF BASE IN C
CAIG C,36.
CAIGE C,2
JRST BASER
PRI2D: HRRZ A,-1(P)
JSP T,FXNV1 ;THE TYO ROUTINE MUST SAVE TT HERE
IFN USELESS,[
MOVMS TT ;ESTIMATE LENGTH OF FIXNUM
JFFO TT,.+2 ; ASSUMING OCTAL BASE
MOVEI D,43
MOVNI T,3
IDIVM D,T ;AVOID CLOBBERING EXTRA ACS
ADDI T,14
SKIPGE @-1(P) ;ALLOW FOR MINUS SIGN
ADDI T,1
PUSHJ P,PRINLP
MOVE TT,@-1(P)
] ;END OF IFN USELESS
CAIN C,8 ;FOR OCTAL NUMBERS, WE MAY WANT
JRST PRI2B ; TO USE A FUNNY SHIFTED FORMAT
PRI2C: JUMPL TT,PRI2Q
SKIPE V.NOPOINT
JRST PRINI2 ;HAPPY PRATT?
CAILE C,10.
%POS%
JRST PRINI2
PRI2Q: %NEG%
PRI2A: MOVNS TT
PRINI2: JSP T,PRI. ;INSERT DECIMAL POINT IF NECESSARY
PRINI9: MOVEI T,1 ;MUST SAVE F - SEE GCPNT1, GCWORRY
TLZN TT,400000 ;IF NUMBER COULD BE MOBY, THEN MOVE HIGH ORDER BIT
PRINI3: SETZ T, .SEE FP4B1 ;MUSTN'T DISTURB B
JSP D,PRINI5
SKIPE TT,T
PUSHJ P,PRINI3
FP7A1: HLRZ A,(P)
FP7B: MOVEI A,"0(A)
CAIE A,".
JRST (R)
%DCML%
POPJ P,
PRINI5: DIVI TT-1,(C)
CAILE TT,9
ADDI TT,"A-"9-1 ;KLUDGY DIGITS GREATER THAN 9 ARE "A, B, C, ..., Y, Z"
PRINI7: HRLM TT,(P)
JRST (D)
PRI.: CAIN C,10. ;IF THE RADIX IS 10.
SKIPE V.NOPOINT ; AND *NOPOINT IS NOT SET,
JRST (T) ; THEN KLUDGILY ARRANGE
HRLI T,".-"0 ; TO PRINT A "." AFTER THE
HLLM T,(P) ; DIGITS ARE PRINTED
PUSH P,[FP7A1]
JRST (T)
;PRI2B PRI2B3 PROMAN PRINRM PRINR0 PRINR1 PRINR2 PRINR3 PRINR4 PRINR5 PRINR6 PRINR9
PRI2B: MOVM D,TT
TRNN D,777
TLNN D,-1
JRST PRI2C
MOVEI T,(C)
MOVE C,VREADTABLE
MOVE D,TT
MOVEI TT,LRCT-1 ;RH OF LAST RCT ENTRY IS (STATUS ←)
HRRZ C,@TTSAR(C)
EXCH T,C
MOVE TT,D
JUMPE T,PRI2C
MOVNI D,11 ;PRINT OUT AS ONE OF:
TRNE TT,777000 ; NNNNNNNNN←11
JRST PRI2B3 ; NNNNNN←22
MOVNI D,22 ; NNN←33
TLNN TT,777 ; N←41
MOVNI D,33 ; IN ORDER THAT LOSERS NEED NOT
TLNN TT,77777 ; COUNT ALL THE ZEROS OF AN
MOVNI D,41 ; OCTAL NUMBER.
PRI2B3: ASH TT,(D)
PUSH FXP,D
PUSHJ P,PRI2C
%BAK%
POP FXP,TT
JRST PRI2A
IFN USELESS,[
PROMAN: AOS (P)
JRST PRINR0
PRINRM: HRRZ A,-1(P)
JSP T,FXNV1
PRINR0: MOVEI C,10.
JUMPLE TT,PRI2D
CAIL TT,4000.
JRST PRI2D
MOVEI T,15.
PUSHJ P,PRINLP
SETZ T,
PRINR1: IDIVI TT,10.
HRLM D,(P)
ADDI T,1
JUMPE TT,PRINR2
PUSHJ P,PRINR1
PRINR2: HLRZ TT,(P)
SUBI T,1
JUMPE TT,CPOPJ
CAIE TT,9
JRST PRINR3
HLRZ A,PRINR9(T)
PUSHJ P,(R)
HLRZ A,PRINR9+1(T)
JRST (R)
PRINR3: CAIE TT,4
JRST PRINR4
HLRZ A,PRINR9(T)
PUSHJ P,(R)
HRRZ A,PRINR9(T)
JRST (R)
PRINR4: CAIGE TT,5
JRST PRINR6
SUBI TT,5
HRRZ A,PRINR9(T)
PRINR5: PUSHJ P,(R)
PRINR6: SOJL TT,CPOPJ
HLRZ A,PRINR9(T)
JRST PRINR5
PRINR9: "I,,"V
"X,,"L
"C,,"D
"M,,
] ;END OF IFN USELESS
;PRINDB DFP0 PRINO FP0 FP0A FP0B FP1 FP3 FP3A FP3A1 FPX0
SUBTTL PRINT A FLONUM (SINGLE OR DOUBLE PRECISION)
IFN DBFLAG,[
PRINDB:
IFN USELESS,[
MOVEI T,30. ;GROSS ESTIMATE OF LENGTH OF DOUBLE
PUSHJ P,PRINLP
] ;END OF IFN USELESS
KA HRRZ A,-1(P)
KA MOVE T,(A)
KA MOVE TT,1(A)
KIKL DMOVE T,@-1(P)
DFP0:
KA MOVEI B,66 ;PRECISION OF "SOFTWARE FORMAT" DOUBLE
KIKL MOVEI B,76 ;PRECISION OF "HARDWARE FORMAT" DOUBLE
JRST FP0A
] ;END OF IFN DBFLAG
PRINO:
IFN USELESS,[
MOVEI T,17. ;GROSS ESTIMATE OF LENGTH OF FLONUM
PUSHJ P,PRINLP
] ;END OF IFN USELESS
MOVE T,@-1(P)
;A FLONUM TO PRINT IS IN T
FP0:
DB$ MOVEI B,33 ;PRECISION OF A FLONUM IN BITS
DB$ SETZ TT,
FP0A: JUMPGE T,FP0B
%NEG%
DB% MOVNS T
DB$ KA DFN T,TT
DB$ KIKL DMOVN T,T
FP0B:
;A POSITIVE FLONUM TO PRINT IS IN T (DB$: AND TT); IF DB$, PRECISION IN BITS IS IN B
FP1:
IFN DBFLAG,[
MOVE F,T ;MAKE A COPY OF NUMBER WITH JUST THE
AND F,[777400,,] ; MOST SIGNIFICANT BIT SET (ASSUME ARG NORMALIZED)
PUSH FXP,F ;THIS WILL BE USED FOR A MASK AFTER SCALING
PUSH FXP,R70 ; DOWN BY THE CONTENTS OF B (PRECISION)
SETZ F, ;F WILL BE THE EXPONENT TO PRINT FOR E/D NOTATION
CAMGE T,[0.1]
] ;END OF IFN DBFLAG
DB% SETZB TT,F ;TT IS SECOND WORD FOR T; F WILL BE EXPONENT
DB% CAMGE T,[0.01]
JRST FP4 ;0.01 (OR 0.1) AND 1.0↑8 ARE CHOSEN SO THAT THE
CAML T,[1.0↑8] ; FRACTIONAL PART WILL HAVE AT LEAST ONE
JRST FP4E0 ; BIT, BUT NOT LOSE ANY OFF THE RIGHT END
DB$ CAILE B,33 ;FOR DOUBLE PRECISION, MUST ARRANGE TO PRINT "D0"
DB$ JRST FP4B1 ; AT THE END OF THE NUMBER
IFE DBFLAG,[
;A POSITIVE FLONUM BETWEEN .01 AND 1.0↑8 IS IN T
FP3: SETZB TT,D
ASHC T,-33 ;SPLIT EXPONENT PART OFF - MANTISSA IN TT
ASHC TT,-243(T) ;SPLIT NUMBER INTO INTEGRAL AND FRACTIONAL PART
MOVSI F,200000 ;COMPUTE POSITION OF LAST SIGNIFICANT BITS
ASH F,-243+<43-33>(T) ;F GETS A VALUE EQUAL TO 1/2 LSB
PUSH FXP,F
PUSH FXP,D ;SAVE FRACTION
MOVEI C,10. ;PRINT INTEGER PART AS A DECIMAL FIXNUM
PUSHJ P,PRINI3
%DCML% ;PRINT DECIMAL POINT
POP FXP,TT
;NOW TT HAS FRACTION INFO BITS, AND (FXP) HAS SLIDING MASK BIT (TOLERANCE)
FP3A: MOVE T,TT ;REMAINING INFO BITS IN TT
MULI T,10. ;T GETS NEXT DIGIT TO PRINT, MORE OR LESS
POP FXP,F
JFCL 8,.+1 ;CLEAR OVERFLOW
IMULI F,10. ;OVERFLOW ON (FSC 231400000001 0) AND (FSC 175631463150 0)
JFCL 8,FP3A1 ;CUT OFF WHEN MASK BIT OVERFLOWS
CAMGE TT,F
JRST FP3A1 ; OR WHEN REMAINING INFO BITS ARE BELOW MASK
MOVN D,F
TLZ D,400000
CAMLE TT,D
AOJA T,FPX0 ;LAST SIG DIGIT, BUT ROUND UPWARDS
PUSH FXP,F
PUSHJ P,FPX0 ;OUTPUT A DIGIT, AND GO AROUND FOR ANOTHER
JRST FP3A
FP3A1: TLNE TT,200000 ;SIZE OF REMAINDER DETERMINES ROUNDING
ADDI T,1
FPX0: MOVEI A,"0(T) ;COME HERE TO OUTPUT A DIGIT IN T
JRST (R)
] ;END OF IFE DBFLAG
IFN DBFLAG,[
;FALLS THROUGH
;FP3
;;; IFN DBFLAG
;FALLS IN
;A POSITIVE FLONUM BETWEEN 0.1 AND 10.0↑8 IS IN T AND TT; PRECISION IN BITS IS IN B
; ON FXP, A TWO-WORD MASK VALUE, AS YET UNSCALED BY THE CONTENTS OF B
FP3:
KA ASH TT,10 ;PUT NUMBER IN HARDWARE FORMAT
LDB F,[331000,,T] ;GET EXPONENT (CANNOT BE LARGER THAN 200+33)
TLZ T,377000 ;CLEAR EXPONENT FROM FRACTION
PUSH FXP,TT
SETZ D,
ASHC TT,-233(F) ;CALCULATE LOW ALIGNED FRACTION WORD
PUSH FXP,D
MOVE TT,-1(FXP)
ASHC T,-233(F) ;CALCULATE HIGH ALIGNED FRACTION WORD
MOVEM TT,-1(FXP) ;INTEGER PART IS IN T
KA MOVE TT,-3(FXP) ;GET MASK INTO TT AND D
KA MOVE D,-2(FXP)
KA ASH D,10 ;CONVERT TO HARDWARE FORMAT
KIKL DMOVE TT,-3(FXP)
LDB F,[331000,,TT] ;GET EXPONENT
TLZ TT,377000 ;CLEAR EXPONENT, LEAVING FRACTION
SUBI F,(B)
ASHC TT,-200+4(F) ;CALCULATE MASK FRACTION VALUE, BINARY POINT BELOW BIT 4.5
KA MOVEM TT,-3(FXP) ;SAVE IT BACK ON FXP
KA MOVEM D,-2(FXP)
KIKL DMOVEM TT,-3(FXP)
MOVE TT,T ;PUT INTEGER PART IN TT
MOVEI C,10. ;PRINT INTEGER PART IN RADIX 10.
PUSHJ P,PRINI3 ;PRESERVES B
%DCML%
POP FXP,TT
POP FXP,T
ASHC T,-4 ;ALIGN FRACTION SO BINARY POINT IS BELOW BIT 4.5
;FALLS THROUGH
;DFP3A DFP3A1 DFP3A2 DFP3A8 DFP3A9
;;; IFN DBFLAG
;FALLS IN
;FRACTION IN T,TT WITH BINARY POINT BELOW BIT 4.5; MASK IN -1(FXP),(FXP)
DFP3A:
IMULI T,10. ;MULTIPLY FRACTION BY 10.
MULI TT,10.
ADD T,TT
MOVE TT,D
LDB A,[370400,,T] ;GET NEXT DIGIT (BITS 4.8-4.5) IN A
MOVEI A,"0(A) ;MAKE IT ASCII
TLZ T,360000 ;FORM REMAINDER IN TT,D
EXCH T,-1(FXP) ;EXCHANGE FRACTION WITH MASK
EXCH TT,(FXP)
IMULI T,10. ;MULTIPLY MASK BY 10.
MULI TT,10.
ADD T,TT
MOVE TT,D
CAMGE T,-1(FXP)
JRST DFP3A1
CAMG T,-1(FXP)
CAMLE TT,(FXP)
JRST DFP3A8 ;LAST DIGIT IF MASK > FRACTION
DFP3A1:
KA SETCM D,T ;NEGATE MASK
KA MOVN F,TT
KA TLZ F,400000
KA SKIPN F
KA ADDI D,1
KIKL MOVE D,T
KIKL MOVE F,TT
KIKL DMOVN T,T
KA TLZ D,760000 ;FORM 1-MASK
KIKL TLZ T,760000
KA CAMLE D,-1(FXP)
KIKL CAMLE T,-1(FXP)
JRST DFP3A2
KA CAML D,-1(FXP)
KIKL CAML T,-1(FXP)
KA CAMGE F,(FXP)
KIKL CAMGE TT,(FXP)
AOJA A,DFP3A9 ;LAST DIGIT, ROUNDED UP, IF FRACTION > 1-MASK
DFP3A2:
KA EXCH T,-1(FXP) ;EXCHANGE BACK MASK FOR FRACTION
KA EXCH TT,(FXP)
KIKL DMOVE T,-1(FXP)
KIKL MOVEM D,-1(FXP)
KIKL MOVEM F,(FXP)
PUSHJ P,(R) ;OTHERWISE OUTPUT DIGIT AND
JRST DFP3A ; GO AROUND AGAIN
DFP3A8: MOVE TT,-1(FXP) ;ROUND LAST DIGIT UP IF FRACTION >= 1/2
TLNE TT,10000
ADDI A,1
DFP3A9: SUB FXP,R70+2
JRST (R)
KIKL D10.0: 10.0 ? 0
KIKL D1.0E8: 1.0↑8 ? 0
] ;END OF IFN DBFLAG
;FP4 FP4A FP4E0 FP4E1 FP4E FP4E2 FP4E2A FP4B FP4B1
;HERE ON FLONUMS < 0.01 (DB%) OR < 0.1 (DB$)
FP4: JUMPN T,FP4E ;FLOATING POINT "E" FORMAT
DB$ CAILE B,33 ;FOR DOUBLE PRECISION,
DB$ PUSH P,[[%D% ? JRST FP4A]] ;PRINT "0.0D0" CLEVERLY
PUSHJ P,FP4A ;CLEVER WAY TO PRINT OUT "0.0" QUICKLY
%DCML%
FP4A: MOVEI A,"0
JRST (R)
;HERE ON FLONUMS >= 1.0E8
FP4E0:
KA FDVL T,[1.0↑8] ;BE DOUBLY PRECISE IN DIVIDING
KA FDVR TT,[1.0↑8] ; BY 10↑8 TO GET NUMBER IN RANGE
KA FADL T,TT
KIKL DFDV T,D1.0E8
IFN DBFLAG,[
EXCH T,-1(FXP)
EXCH TT,(FXP)
KA FDVL T,[1.0↑8] ;DIVIDE MASK TOO
KA FDV TT,[1.0↑8] ;UNROUNDED!
KA FADL T,TT
KIKL DFDV T,D1.0E8
EXCH T,-1(FXP)
EXCH TT,(FXP)
] ;END OF IFN DBFLAG
ADDI F,8
CAML T,[1.0↑8]
JRST FP4E0 ;KEEP DIVIDING UNTIL < 10↑8
FP4E1: CAMGE T,[10.0]
JRST FP4B
KA FDVL T,[10.0] ;NOW REDUCE UNTIL < 10.0
KA FDVRI TT,(10.0)
KA FADL T,TT
KIKL DFDV T,D10.0
IFN DBFLAG,[
EXCH T,-1(FXP)
EXCH TT,(FXP)
KA FDVL T,[10.0] ;DIVIDE MASK TOO
KA FDV TT,[10.0] ;UNROUNDED!
KA FADL T,TT
KIKL DFDV T,D10.0
EXCH T,-1(FXP)
EXCH TT,(FXP)
] ;END OF IFN DBFLAG
AOJA F,FP4E1
;HERE FOR NON-ZERO FLONUMS < 0.01 (DB%) OR < 0.1 (DB$)
FP4E: CAML T,[1.0↑-8] ;BE DOUBLY PRECISE IN MULTIPLYING BY 10↑8
JRST FP4E2A
KA FMPR TT,[1.0↑8]
KA MOVEM TT,D
KA FMPL T,[1.0↑8]
KA UFA TT,D
KA FADL T,D
KIKL DFMP T,D1.0E8
IFN DBFLAG,[
EXCH T,-1(FXP)
EXCH TT,(FXP)
KA FMP TT,[1.0↑8] ;UNROUNDED! MULTIPLY MASK TOO
KA MOVEM TT,D
KA FMPL T,[1.0↑8]
KA UFA TT,D
KA FADL T,D
KIKL DFMP T,D1.0E8
EXCH T,-1(FXP)
EXCH TT,(FXP)
] ;END OF IFN DBFLAG
SUBI F,8
JRST FP4E
FP4E2:
KA FMPRI TT,(10.0) ;NOW INCREASE UNTIL >= 1.0
KA MOVEM TT,D
KA FMPL T,[10.0]
KA UFA TT,D
KA FADL T,D
KIKL DFMP T,D10.0
IFN DBFLAG,[
EXCH T,-1(FXP)
EXCH TT,(FXP)
KA FMP TT,[10.0] ;UNROUNDED! MULTIPLY MASK TOO
KA MOVEM TT,D
KA FMPL T,[10.0]
KA UFA TT,D
KA FADL T,D
KIKL DFMP T,D10.0
EXCH T,-1(FXP)
EXCH TT,(FXP)
] ;END OF IFN DBFLAG
FP4E2A: CAMGE T,[1.0]
SOJA F,FP4E2
;HERE WHEN NUMBER BETWEEN 1.0 (INCL) AND 10.0 (EXCL); F IS THE EXPONENT TO BE PRINTED.
FP4B:
IFE DBFLAG,[
KIKL TLNN TT,200000 ;DECIDE WHETHER ROUNDING WILL HAVE ANY EFFECT
KIKL JRST FP4B1
KIKL HLLZ TT,T ;IF SO, CREATE A FLONUM WHOSE VALUE IS
KIKL TLZ TT,777 ; 1/2 LSB OF FRACTION IN T
KIKL ADD TT,[777000,,1]
FADR T,TT ;ADD LOW PART TO HIGH PART, ROUNDING
CAMGE T,[10.0] ;ROUNDING UP MAY TAKE US OUT OF RANGE AGAIN
JRST FP4B1
FDVRI T,(10.0)
ADDI F,1 ;ADJUST EXPONENT FOR THE DIVISION
] ;END OF IFE DBFLAG
;FOR DB$, JUST LET THE EXTRA INFO BITS SIT THERE, EVEN FOR SINGLE PRECISION!
; AFTER ALL, THE MASK HAS ALSO BEEN COMPUTED TO DOUBLE PRECISION
FP4B1: PUSH FLP,F ;DON'T USE FXP! WILL CONFLICT WITH MASK FOR DB$
PUSHJ P,FP3 ;NUMBER HAS BEEN NORMALIZED FOR 1.0 .LE. X < 10.0
DB$ CAILE B,33
DB$ %D% ;FOR DOUBLE PRECISION, "D" INDICATES EXPONENT
DB$ CAIG B,33
%E% ;FOR SINGLE PRECISION, "E" INDICATES EXPONENT
POP FLP,TT ;POP EXPONENT
SKIPLE TT ;PRINT SIGN (BUT PRINT NO SIGN FOR 0)
%POS%
SKIPGE TT
%NEG%
MOVEI C,10.
MOVMS TT
JRST PRINI3 ;PRINT EXPONENT AS A DECIMAL INTEGER
;PRINCX PRNCX2 PRNCX3 PRNCX4 PRINDX PRNDX2 PRNDX5
SUBTTL PRINT A COMPLEX OR A DUPLEX
IFN CXFLAG,[
PRINCX:
IFN USELESS,[
MOVEI T,35.
SKIPN @-1(P)
MOVEI T,18.
PUSHJ P,PRINLP
] ;END OF IFN USELESS
SKIPE T,@-1(P) ;DON'T PRINT REAL PART IF 0
PUSHJ P,FP0
KA HRRZ A,-1(P)
KA MOVE T,(A)
KA MOVE TT,1(A)
KIKL DMOVE T,@-1(P)
JUMPE T,PRNCX2
SKIPL TT
%POS%
PRNCX2: JUMPE TT,PRNCX4
SKIPGE TT
%NEG%
MOVM T,TT
PUSHJ P,FP0
PRNCX3: MOVEI A,"J ;CROCK
JRST (R)
PRNCX4: MOVEI A,"0
PUSHJ P,(R)
JRST PRNCX3
] ;END OF IFN CXFLAG
IFN DXFLAG,[
PRINDX:
IFN USELESS,[
MOVEI T,60.
SKIPN @-1(P)
MOVEI T,30.
PUSHJ P,PRINLP
] ;END OF IFN USELESS
KA HRRZ A,-1(P)
KA MOVE T,(A)
KA MOVE TT,1(A)
KIKL DMOVE T,@-1(P)
SKIPE T ;DON'T PRINT REAL PART IF 0
PUSHJ P,DFP0
HRRZ A,-1(P)
KA MOVE T,2(A)
KA MOVE TT,3(A)
KIKL DMOVE T,2(A)
SKIPN @-1(P)
JRST PRNDX2
SKIPL T
%POS%
PRNDX2: JUMPE T,PRNCX4
SKIPGE T
%NEG%
JUMPGE T,PRNDX5
KA DFN T,TT
KIKL DMOVN T,T
PRNDX5: PUSHJ P,DFP0
JRST PRNCX3
] ;END OF IFN DXFLAG
;PRINB PRINB0 PRINBQ PRINBZ PRBAB PRINB3 PNFBLP
IFN BIGNUM,[
SUBTTL PRINT A BIGNUM
PRINB:
IFN USELESS,[
HRRZ B,@-1(P)
MOVEI T,1
PRINB0: ADDI T,12.
HRRZ B,(B)
JUMPN B,PRINB0
PUSHJ P,PRINLP
] ;END OF IFN USELESS
HRRZ A,-1(P)
SKIPGE A,(A)
JRST PRINBQ
IFE USELESS, HRRZ D,@VBASE
IFN USELESS,[
HRRZ D,VBASE
CAIE D,QROMAN
SKIPA D,(D)
MOVEI D,10.
] ;END OF IFN USELESS
CAILE D,10.
%POS%
JRST PRINBZ
PRINBQ: %NEG% ;NEGATIVE BIGNUM
PRINBZ: MOVEM R,RSAVE
HRRZM P,FSAVE ;STORE PDL POSITION SO AR1 AND AR2A CAN BE FOUND
PUSH P,AR1
PUSH P,AR2A
PUSHJ P,YPOCB
PUSH P,A
PUSH P,[PRINB4]
MOVE B,VBASE
IFN USELESS,[
CAIN B,QROMAN
SKIPA D,[10.]
] ;END OF IFN USELESS
JSP T,FXNV2
MOVE C,D
JSP T,PRI.
MOVE R,D
MOVEI F,1
MOVE T,D
PRBAB: MUL T,D
JUMPN T,.+4
MOVE T,TT
MOVE R,TT
AOJA F,PRBAB
MOVEM F,NORMF
MOVE D,R
PRINB3: MOVE C,A
HLRZ B,(C)
MOVE F,(B)
MOVEI R,0
PNFBLP: DIV R,D
MOVEM R,(B)
MOVE B,(C)
TRNN B,-1
JRST PRBFIN
MOVE C,(C)
MOVE R,F
HLRZ B,(C)
MOVE F,(B)
JRST PNFBLP
;PRBFNA PRBFIN PRINBI PRINBJ PRBNUF PRINB4
PRBFNA: HLR A,B
PRBFIN: MOVS B,(A)
TLNE B,-1
SKIPE (B)
JRST .+2
JRST PRBFNA
PUSH FXP,F
MOVE R,(A)
TRNN R,-1
JRST PRBNUF
PUSHJ P,PRINB3
PRINBI: POP FXP,TT
MOVE F,NORMF
MOVE R,RSAVE
PRINBJ: SETZ T,
JSP D,PRINI5
SOJE F,FP7A1
MOVE TT,T
PUSHJ P,PRINBJ
JRST FP7A1
PRBNUF: HLRZ A,R
MOVE TT,(A)
MOVE AR2A,FSAVE
MOVE AR1,1(AR2A) ;RESTORE AR1 AND AR2A
MOVE AR2A,2(AR2A)
HRRZ C,VBASE
IFN USELESS, CAIN C,QROMAN
IFN USELESS, SKIPA R,[10.]
JSP T,FXNV3
MOVE C,R
MOVE R,RSAVE
SKIPE TT
PUSHJ P,PRINI3
JRST PRINBI
PRINB4: POP P,A
MOVEI B,TRUTH
PUSHJ P,RECLAIM
POP P,AR2A
POP P,AR1
POPJ P,
] ;END OF IFN BIGNUM
;FLATSIZE FLAT4 FLAT3 FLAT2 CFLAT2 FLATC FLATC1 FLATC2 FLATC3 $EXPLODEC $$EXPLODEN EXPLY1 EXPLY2 EXPLY3 EXPLY4 EXPLY9
SUBTTL FLATSIZE, FLATC, EXPLODEC, EXPLODEN, EXPLODE
FLATSIZE:
PUSH P,CFIX1 ;SUBR 1
SKIPA R,CFLAT2 ;POPJ IS POSITIVE
FLAT4: HRROI R,FLAT2
FLAT3: SETZM FLAT1
PUSHJ P,PRINTF
SKIPA TT,FLAT1
FLAT2: AOS FLAT1
CFLAT2: POPJ P,FLAT2
FLATC: PUSH P,CFIX1 ;SUBR 1
JSP T,SPATOM
JRST FLAT4
JUMPN A,FLATC1
MOVEI TT,3 ;FLATC OF NIL IS 3
POPJ P,
FLATC1: HLRZ TT,(A) ;FAST-FLATC FOR SYMBOLS
HRRZ A,1(TT)
SETZ TT,
FLATC2: HRRZ B,(A) ;COUNT 5 CHARS PER PNAME WORD
ADDI TT,BYTSWD
JUMPE B,FLATC3
HRRZ A,(B)
ADDI TT,BYTSWD
JUMPN A,FLATC2
MOVEI A,(B)
FLATC3: HLRZ A,(A) ;LAST PNAME WORD MAY BE PARTIAL
SKIPN T,(A) ;WATCH OUT FOR NULL PNAME!
SUBI TT,1
TRNE T,177←1
POPJ P,
TRNE T,177←10
SOJA TT,CPOPJ
SUBI TT,3
TDNE T,[177←17]
AOJA TT,CPOPJ
TLNN T,(177←26)
SUBI TT,1
POPJ P,
$EXPLODEC:
SKIPA R,EXPLODE ;SUBR 1 ;HRRZI IS NEGATIVE!!!
$$EXPLODEN:
HRROI R,EXPL2 ;SUBR 1
SKOTT A,SY
JRST EXPL4
HLRZ T,(A)
HRRZ A,1(T)
PUSH P,R70 ;FORMING LIST OF CHARS
MOVEI B,(P)
PUSH P,A
PUSH P,B
XOR R,EXPLODE
PUSH FXP,R
EXPLY1: SKIPN A,-1(P)
JRST EXPLY9
HLRZ B,(A)
MOVE D,(B)
HRRZ A,(A)
MOVEM A,-1(P)
EXPLY2: JUMPE D,EXPLY1
SETZ TT,
LSHC TT,7
SKIPE (FXP)
JRST EXPLY3
PUSH FXP,D
PUSHJ P,RDCH2
POP FXP,D
JRST EXPLY4
EXPLY3: MOVEI A,IN0(TT) .SEE HINUM
EXPLY4: PUSHJ P,NCONS
HRRM A,@(P)
HRRZM A,(P)
JRST EXPLY2
EXPLY9: SUB P,R70+2
SUB FXP,R70+1
JRST POPAJ
;EXPLODE EXPL4 EXPL1 EXPL3 EXPL6 EXPL2
EXPLODE: HRRZI R,EXPL1 ;SUBR 1
EXPL4: PUSH P,R70
HRRZM P,EXPL5
PUSHJ P,PRINTF
JRST POPAJ
EXPL1: SAVE B C
SAVEFX TT R
ANDI A,177
PUSHJ P,RDCH3
POP P,C
EXPL3: PUSHJ P,NCONS
HRRM A,@EXPL5
HRRZM A,EXPL5
EXPL6: RSTRFX R TT
JRST POPBJ
EXPL2: PUSH P,B
SAVEFX TT R
MOVEI A,IN0(A)
JRST EXPL3
;BAKTRACE BAKLIST BKTR0 BKTR3 BKTR2 BKTR1 BKTR2X
SUBTTL BAKTRACE
BAKTRACE: ;PRINT A BAKTRACE
JSP TT,LWNACK
LA01,,QBAKTRACE
MOVNI TT,1
JRST BKTR0
BAKLIST: ;RETURN A LIST (SIMILAR TO PRINTED FORMAT)
JSP TT,LWNACK
LA01,,QBAKLIST
MOVSI TT,400000
BKTR0: MOVEM TT,BACTYF ;TYPE FLAG FOR BAKTRACE/BAKLIST
MOVEI A,NIL ;START WITH NIL
SKIPE T ;OR USER SUPPLIED ARG
POP P,A
JSP R,GTPDLP ;GET APPROPRIATE PDL POINTER
0
JFCL
MOVEI A,(D) ;SAVE PDL POINTER IN A
MOVE B,(A) ;GET TOP OF STACK
CAME B,[QBAKTRACE,,CPOPJ]
CAMN B,[QBAKLIST,,CPOPJ]
SOS A ;SKIP FIRST SLOT IF CALL TO US
MOVEI R,60 ;LOOK AT ABOUT 60 STACK LOCATIONS
HRRZ TT,C2 ;GET PDL ORIGION
SUBM A,TT ;SAVE PDL OFFSET IN TT
CAIG TT,(R) ;FEWER THAN 60 LOCATIONS TO LOOK AT?
MOVE R,TT ;YES, SO LOOK AT THAT MANY
MOVE T,A
SETZM CPJSW ;ASSUME *RSET HAS BEEN OFF
MOVEI B,CPOPJ
BKTR3: MOVE TT,(T) ;CUT OUT STUFF FROM *RSET LOOP, IF USED
CAIN B,(TT)
TLNN TT,-1
SKIPA
SETOM CPJSW ;APPARENTLY *RSET HAS BEEN ON
TLZ TT,-1#10000
CAMN TT,[10000,,LSPRET]
MOVEI A,-1(T)
SOS T
SOJG R,BKTR3
MOVEM A,BKTRP ;SET UP FOR BAKTRACE LOOP AND GO THERE
MOVE A,BACTYF
AOJE A,BKTR2 ;IF TRACING THEN SKIP LIST HACKING STUFF
PUSH P,R70 ;SET UP LIST TO HOLD BAKLISTING
HRLM P,(P) ;SET UP LAST-OF-LIST POINTER
BKTR2: HRRZ A,C2 ;THE PDL-HUNTING LOOP
ADDI A,1
CAML A,BKTRP
JRST BKTR2X ;EXIT WHEN BACKED UP TO BOTTOM OF PDL
AOSN BACTYF
STRT [SIXBIT \↑MBAKTRACE↑M!\]
HRRZ A,@BKTRP
CAIN A,CPOPJ ;IN *RSET MODE, THIS IS A TAG
JRST BKTR1C ;PUT ON PDL UPON ENTRY TO A FUNCTION
CAIN A,ILIST3
JRST BKTR1B
MOVE D,@BKTRP
TLNE D,10000#-1 ;TO BE A PUSHJ RETURN ADDR, THERE MUST
CAIN A,BKCOM1 ; BE PC FLAGS IN LH
JRST BKTR1
CAIL A,BEGFUN
CAIL A,ENDFUN
JRST BKTR1A
CAIE A,CON2
CAIN A,CON3
JRST BKTR1G
CAIN A,PG0A
JRST BKTR1E
CAIN A,LMBLP1
JRST BKTR1
CAILE A,BRLP1
CAILE A,BRLP2
SKIPA
JRST BKTR1H
CAIN A,REKRD1
JRST BKTRR3
CAIE A,UNBIND
JRST BKTR1A
BKTR1: SOS BKTRP
JRST BKTR2
BKTR2X: AOSE BACTYF
SKIPL BACTYF
JRST TERPRI
POP P,A
JRST RHAPJ
;BKTR1A BK1A2 BK1A4 BK1A1 BK1A1C BK1A3 BK1A1B
BKTR1A: CAMGE A,@VBPORG ;LETS HOPE THAT BPORG ISN'T SCREWED UP
CAIGE A,BBPSSG
JRST BKTR1
BK1A2: MOVEI AR1,-1(A)
BK1A4: HLRZ B,-1(A) ;SOMEWHERE IN BINARY PROGRAMS
MOVEI R,PRIN1B ;IF "CALL", THEN SUBR ATOM NAME WILL BE IN B
TRC B,37 ;LIKELY NOT AN INSTRUCTION IF ALL THE INDIRECT,
TRCE B,37 ; AND INDEXING BITS ARE ONES
CAIGE B,(CALL )
JRST BKTR1
CAIG B,(JCALLF 17,)
JRST BK1A1
CAIE B,(XCT) ;MIGHT BE A XCT OF A CALL, JRST, PUSHJ TO SUBR
JRST .+3
HRRZ A,-1(A) ;IF SO, CYCLE TO TRY TO FIND CALLED SUBR NAME
AOJA A,BK1A4
MOVEI R,ERRADR ;HA! MAYBE PUSHJ OR JRST, SO NOW WE HAVE
CAIN B,(JRST 0,) ; ONLY BEGINNING ADDRESS OF SUBR. HENCE
JRST BK1A1 ; IT HAS TO BE DECODED INTO ATOM NAME.
CAIE B,(PUSHJ P,)
JRST BKTR1 ;LOSE, DON'T KNOW WHAT KIND OF INST THIS IS
HLLZ B,@BKTRP
TLNN B,10000 ;USER MODE FLAG - STOPS RANDOM
JRST BKTR1 ; DATA NOT ENTERED BY PUSHJ
BK1A1: MOVE B,-1(A) ;EITHER "(J)CALL(F)", "JRST", OR "PUSHJ P,"
TLNE B,7777760 ;LET INDIRECTION HAPPEN, BUT CAN'T CHANCE
TLNE B,((17)) ; DOING IT IF THE UUO IS INDEXED, OR
JRST BK1A1B ; ADDRESSES AN AC
MOVEI B,@-1(A) ;LET INDIRECT DO ITS THING
BK1A1C: PUSH P,AR1 ;ORIGINAL PC WHEREFROM SUBR WAS CALLED
SKIPGE BACTYF
JRST BK1A3
PUSHJ P,(R) ;R HAS EITHER PRIN1B OR ERRADR
STRT [SIXBIT \←!\] ; DEPENDING ON WHETHER "CALL" OR "PUSHJ P,"
POP P,B
PUSHJ P,ERRADR
STRT [SIXBIT \ !\]
JRST BKTR1
BK1A3: CAIE R,ERRADR
SKIPA A,B
PUSHJ P,ERRDCD ;"ERRDCD" DECODES ADDRESS IN B, GETS ATOM IN A
EXCH A,(P)
PUSHJ P,ERRDCD
PUSH P,[QLA]
PUSH P,A
MOVNI T,3
JRST BKT1F2
BK1A1B: CAIN R,ERRADR
TDZA B,B
MOVEI B,QM
JRST BK1A1C
;BKTR1B BKTR1C BKTR1F BKT1B1 BKT1F1 BKT1F2 BKTR1H BKTR1E BKTR1D BKTR1G BKTR1I BKTRR3 BKTRR5 UREAD UREAD2 UREAD1 UREOF UCLOSE
BKTR1B: MOVE D,BKTRP
HRRZ B,-1(D) ;PROBABLY FOR ENTRY TO SOME SUBR, LSUBR, OR EXPR
CAIE B,ELSB1 ;LISTING TINGS UP ON THE PDL
CAIN B,ESB1
JRST .+3
CAIE B,IAPPLY
JRST BKTR1
HLRE B,-1(D)
ADDI B,-3(D)
HLRZ A,(B)
JUMPE A,BKTR1
HRRZM B,BKTRP
SKIPGE BACTYF
JRST BKT1B1
STRT [SIXBIT \(!\]
PUSHJ P,PRINC
STRT [SIXBIT \ EVALARGS) !\]
JRST BKTR1
BKTR1C: HLRZ A,@BKTRP ;PROBABLY ENTERED AN F-TYPE FUNCTION
JUMPE A,BKTR1 ;WELL, NIL ISN'T REALLY A FUNCTION
BKTR1F: SKIPGE BACTYF
JRST BKT1F1
PUSHJ P,PRINC
STRT [SIXBIT \← !\]
JRST BKTR1
BKT1B1: SKIPA B,[QEVALARGS]
BKT1F1: MOVEI B,QLA
PUSH P,A
PUSH P,B
MOVNI T,2
BKT1F2: PUSHJ FXP,LISTX
PUSHJ P,NCONS
HLRZ B,(P)
HRRM A,(B) ;NCONC MOST RECENT GOODIE ONTO END OF LIST
HRLM A,(P) ;UPDATE LAST-OF-LIST POINTER
JRST BKTR1
BKTR1H: MOVNI T,LERSTP+5-1 ;2 FROM BREAK, 2 FROM EDERRL, 1 FROM BRLP = 5
MOVEI A,QBREAK ;-1 SINCE BKTR1 WILL TAKE OFF ONE MORE
JRST BKTR1D
BKTR1E: MOVNI T,LPRP ;BACK UP OFF A PROG
MOVEI A,QPROG
BKTR1D: ADDM T,BKTRP
JRST BKTR1I
BKTR1G: MOVEI A,QCOND ;FOUND A COND ENTRY
BKTR1I: SKIPE CPJSW
JRST BKTR1 ;IF *RSET WAS ON, ENTRY IS BE MARKED BY CPOPJ
JRST BKTR1F
BKTRR3: SKIPA T,XC-3
BKTRR5: MOVNI T,5
ADDM T,BKTRP
JRST BKTR1
PGTOP PRT,[PRINT,TYO,EXPLODE,FLATC,BAKTRACE,ETC]
;;@ END OF PRINT 231
;;@ ULAP 133 UTAPE, LAP, AND AGGLOMERATED SUBRS
;;; ***** MACLISP ****** UTAPE, LAP, AND AGGLOMERATED SUBRS ******
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT [UIO]
SUBTTL OLD I/O FUNCTIONS IN TERMS OF NEW I/O PRIMITIVES
;;; (DEFUN UREAD FEXPR (FILENAME)
;;; (UCLOSE)
;;; ((LAMBDA (FILE)
;;; (EOFFN UREAD
;;; (FUNCTION
;;; (LAMBDA (EOFFILE EOFVAL)
;;; (UCLOSE)
;;; EOFVAL)))
;;; (INPUSH (SETQ UREAD FILE))
;;; (DEFAULTF FILE))
;;; (OPEN (*UGREAT FILENAME) 'IN)))
UREAD: PUSH P,A ;FEXPR
PUSHJ P,UCLOSE
POP P,A
PUSHJ P,UGREAT
PUSH P,[UREAD2]
PUSH P,A
MOVNI T,1
JRST $EOPEN
UREAD2: MOVEM A,VUREAD
PUSH P,[UREAD1]
PUSH P,A
PUSH P,[QUREOF]
MOVNI T,2
JRST EOFFN
UREAD1: HRRZ A,VUREAD
PUSHJ P,INPUSH
PUSHJ P,DEFAULTF
HRRZ A,VUREAD
JRST TRUENAME ;RETURN TRUENAME OF FILE TO USER
UREOF: PUSH P,B ;+INTERNAL-UREAD-EOFFN - SUBR 2
PUSHJ P,UCLOSE
JRST POPAJ
;;; (DEFUN UCLOSE FEXPR (X)
;;; (COND (UREAD
;;; ((LAMBDA (OUREAD)
;;; (AND (EQ OUREAD INFILE) (INPUSH -1))
;;; (SETQ UREAD NIL)
;;; (CLOSE OUREAD))
;;; UREAD))
;;; (T NIL)))
UCLOSE: SKIPN A,VUREAD ;FEXPR
POPJ P,
CAMN A,VINFILE
PUSHJ P,INPOP ;SAVES A
SETZM VUREAD
JRST $CLOSE
;UAPPEND UWRITE UWRT0 UWRT1 UWRT2
;;; (DEFUN UWRITE FEXPR (DEVDIR)
;;; (OR DEVDIR (SETQ DEVDIR (CAR (DEFAULTF NIL))))
;;; (*UWRITE (CONS DEVDIR
;;; (COND ((STATUS FEATURE DEC10)
;;; (CONS (STATUS JNAME) '(OUT)))
;;; ((STATUS FEATURE DEC20)
;;; '(MACLISP OUTPUT))
;;; ((STATUS FEATURE ITS)
;;; '(.LISP. OUTPUT))))
;;; 'OUT
;;; (LIST DEVDIR)))
;;;
;;; (DEFUN UAPPEND FEXPR (FILENAME)
;;; (SETQ FILENAME (*UGREAT FILENAME))
;;; (*UWRITE FILENAME 'APPEND FILENAME))
;;;
;;; (DEFUN *UWRITE (NAME MODE NEWDEFAULT) ;INTERNAL ROUTINE
;;; (COND (UWRITE
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (CLOSE UWRITE)
;;; (SETQ UWRITE NIL)))
;;; ((LAMBDA (FILE)
;;; (SETQ OUTFILES
;;; (CONS (SETQ UWRITE FILE)
;;; OUTFILES))
;;; (CAR (DEFAULTF NEWDEFAULT)))
;;; (OPEN NAME MODE)))
UAPPEND: PUSHJ P,UGREAT ;FEXPR
MOVEI C,(A)
MOVEI B,QAPPEND
JRST UWRT1
UWRITE: JUMPN A,UWRT0 ;FEXPR
PUSHJ P,DEFAULTF
HLRZ A,(A)
UWRT0: PUSHJ P,NCONS
IFN ITS+D20,[
MOVEI C,(A)
HLRZ A,(C)
MOVEI B,QLSPOUT
PUSHJ P,CONS
] ;END OF IFN ITS+D20
IFN D10,[
PUSH P,A
PUSHJ P,SJNAME
MOVEI B,Q$OUT
PUSHJ P,CONS
POP P,C
HLRZ B,(C)
PUSHJ P,XCONS
] ;END OF IFN D10
MOVEI B,Q$OUT
UWRT1: PUSH P,C ;*UWRITE BEGINS HERE
PUSH P,[UWRT2]
PUSH P,A
PUSH P,B
SKIPE VUWRITE
PUSHJ P,UFILE5
MOVNI T,2
JRST $OPEN
UWRT2: MOVEM A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,CONS
MOVEM A,VOUTFILES
POP P,A
PUSHJ P,DEFAULTF
JRST $CAR
;UFILE0 UFILE UFILE5 SCRUNIT CRUNIT
;;; (DEFUN UFILE FEXPR (SHORTNAME)
;;; (COND ((NULL UWRITE)
;;; (ERROR 'NO/ UWRITE/ FILE
;;; (CONS 'UFILE SHORTNAME)
;;; 'IO-LOSSAGE))
;;; (T (PROG2 NIL
;;; (DEFAULTF (RENAMEF UWRITE (*UGREAT SHORTNAME)))
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (SETQ UWRITE NIL)
;;; (OR OUTFILES (SETQ ↑R NIL))))))
UFILE0: MOVEI B,QUFILE
PUSHJ P,XCONS
IOL [NO UWRITE FILE!]
UFILE: SKIPN VUWRITE ;FEXPR
JRST UFILE0
PUSHJ P,UGREAT
MOVEI B,(A)
SETZ A,
EXCH A,VUWRITE
PUSH P,A
PUSH P,B
HRRZ B,VOUTFILES
PUSHJ P,.DELQ
MOVEM A,VOUTFILES
SKIPN VOUTFILES
SETZM TAPWRT
POP P,B
POP P,A
PUSHJ P,$RENAME ;CLOSES THE FILE AS WELL AS RENAMES IT
PUSHJ P,DEFAULTF
POPJ P,
UFILE5: HRRZ A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,.DELQ
MOVEM A,VOUTFILES
HRRZ A,VUWRITE
PUSHJ P,$CLOSE
SETZM VUWRITE
SKIPN VOUTFILES
SETZM TAPWRT
POPJ P,
;;; (DEFUN CRUNIT FEXPR (DEVDIR)
;;; (CAR (DEFAULTF (AND DEVDIR (LIST DEVDIR)))))
SCRUNIT: SETZ A,
CRUNIT: SKIPE A ;FEXPR
PUSHJ P,NCONS
PUSHJ P,DEFAULTF
JRST $CAR
;UGREAT UGRT1 UPROBE UKILL
;;; (DEFUN *UGREAT (NAME) ;INTERNAL ROUTINE
;;; (MERGEF NAME
;;; (COND ((STATUS FEATURE DEC10) '(* . LSP))
;;; ((STATUS FEATURE DEC20) '(* MACLISP *))
;;; ((STATUS FEATURE ITS) '(* . >)))))
UGREAT: PUSH P,[6BTNML]
UGRT1: PUSHJ P,FIL6BT
IFN ITS+D10,[
REPEAT 3, PUSH FXP,[SIXBIT \*\]
IT$ PUSH FXP,[SIXBIT \>\]
SA$ PUSH FXP,[SIXBIT \←←←\]
SA% 10$ PUSH FXP,[SIXBIT \LSP\]
10$ SETOM -2(FXP) ;FOR D10 DEFAULT PPN IS -1
] ;END OF IFN ITS+D10
IFN D20,[
PUSHN FXP,L.F6BT
MOVEI T,-L.6EXT-L.6VRS+1(FXP)
HRLI T,[ASCII \MACLISP\]
BLT T,-L.6EXT-L.6VRS+2(FXP)
] ;END OF IFN D20
JRST IMRGF
;;; (DEFUN UPROBE FEXPR (FILENAME)
;;; (SETQ FILENAME (MERGEF (*UGREAT FILENAME) NIL))
;;; (PROBEF FILENAME))
UPROBE: PUSHJ P,UGRT1 ;FEXPR
JRST PROBF0
;;; (DEFUN UKILL FEXPR (FILENAME)
;;; (DEFAULTF (DELETEF FILENAME))))
UKILL: PUSHJ P,$DELETEF
JRST DEFAULTF
;TTSR TTSR1
SUBTTL SYMBOL MANIPULATION AND SQUOZE FUNCTIONS
;;; (TTSR| <SYMBOL>) GETS THE ARRAY PROPERTY OF <SYMBOL>,
;;; OR GIVES IT AN ARRAY PROPERTY WITH A DEAD SAR;
;;; IT MARKS THE SAR AS BEING NEEDED BY COMPILED CODE,
;;; AND THEN RETURNS THE ADDRESS OF THE TTSAR AS A FIXNUM.
;;; THIS IS USED PRIMARILY BY LAP.
TTSR: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE (TTSR|)
MOVEI C,(A) ;SAVES AR1,R,F - SEE FASLOAD
PUSHJ P,ARGET
JUMPN A,TTSR1
JSP T,SACONS
MOVEI T,ADEAD
MOVEM T,ASAR(A)
MOVE T,[TTDEAD]
MOVEM T,TTSAR(A)
MOVEI B,(A)
MOVEI A,(C)
MOVEI C,QARRAY
PUSHJ P,PUTPROP
TTSR1: MOVSI T,TTS.CN
IORM T,TTSAR(A)
MOVEI TT,1(A)
POPJ P,
;RSQUEEZE SQUEEZE SQZCHR SQOK SQNOTL SQNOTD SQ%$
;;; BOTH ROUTINES ALWAYS RETURN THE LEFT-JUSTIFIED SQUOZE IN T
;;; RSQUEEZE MAY LEAVE RIGHT-JUSTIFIED SQUOZE IN TT
RSQUEEZE: ;CANONICAL SQUOZE CONVERSION
IT% HRROS (P) ;FOR DEC-10, GIVES DEC-10 SQUOZE
SQUEEZE: ;THIS ALWAYS GIVES LEFT-JUSTIFIED SQUOZE
MOVEI AR1,6 ;CONVERT PNAME-ATOM TO SQUOZE AND SIXBIT
MOVE AR2A,[440600,,SQ6BIT] ;RETURNS SQUOZE IN TT, SIXBIT IN SQ6BIT
SETZM SQ6BIT ;CLEAR LOCS USED TO ACCUMULATE
SETZM SQSQOZ ; SIXBIT AND SQUOZE
HRROI R,SQZCHR
PUSHJ P,PRINTA ;"PRINT" OUT CHARS OR PNAME
IT% MOVE TT,SQSQOZ
SKIPA T,SQSQOZ
IMULI T,50
SOJGE AR1,.-1 ; MULTIPLY ITS SQUOZE UP TO SIZE
IT% MOVE R,(P)
IT% TLNN R,1
MOVE TT,T
POPJ P,
SQZCHR: TLNN AR2A,770000 ;IGNORE MORE THAN 6 CHARS
POPJ P,
SUBI A,40 ;CONVERT TO SIXBIT
CAIL A,1 ;LOSSAGE IF NOT SIXBIT CHAR
CAILE A,77 ; - ALSO, SPACE IS A LOSS
MOVEI A,'. ;LOSING NON-SQUOZE CHAR
IDPB A,AR2A ;DEPOSIT SIXBIT CHAR
CAIL A,'A ;CHECK FOR LETTER
CAILE A,'Z
JRST SQNOTL
SUBI A,'A-13 ;CONVERT TO SQUOZE VALUE
SQOK: EXCH T,SQSQOZ
IMULI T,50
ADDI T,(A)
EXCH T,SQSQOZ
SOJA AR1,CPOPJ ;DECR COUNT AND RETURN TO PRINTA
SQNOTL: CAIL A,'0 ;CHECK FOR DIGIT
CAILE A,'9
JRST SQNOTD
SUBI A,'0-1 ;CONVERT TO SQUOZE VALUE
JRST SQOK
SQNOTD: CAIE A,'$ ;CHECK FOR $ OR %
CAIN A,'%
JRST SQ%$
MOVEI A,'. ;ANY CHAR OTHER THAN A-Z, 0-9, $, OR %
DPB A,AR2A ; DEFAULTS TO . (E.G. *FOOBAR -> .FOOBA)
MOVEI A,45-42
SQ%$: ADDI A,42 ;SQUOZE VALUE FOR $,%,.
JRST SQOK
;5BTWD $5BTWD 5BTWD0 5BTWD1 5BTWD9 UNSQOZ UNSQZ1 UNSQZ2 UNSQZ3
5BTWD: PUSH P,CFIX1
$5BTWD: PUSH FXP,R70
5BTWD0: MOVEI C,(A)
HRRZ B,(A)
JUMPE B,5BTWD1
HLRZ A,(A)
JSP T,FXNV1
LSH TT,-2
MOVEM TT,(FXP)
MOVEI A,(B)
5BTWD1: HLRZ A,(A)
JSP T,SPATOM
JRST 5BTWD9
PUSHJ P,SQUEEZE
MOVE R,SQ6BIT
POP FXP,D
DPB D,[400400,,TT]
POPJ P,
5BTWD9: SETZM (FXP)
MOVEI A,(C)
WTA [BAD ARG - SQUOZE!]
JRST 5BTWD0
UNSQOZ: LDB T,[004000,,D] ;HAIRY MESS TO CONVERT
SETZM LD6BIT ; SQUOZE TO SIXBIT
UNSQZ1: IDIVI T,50 ;(THIS IS SEPARATE ROUTINE SO
JUMPE TT,UNSQZ2 ; LAP LOSERS CAN USE IT)
CAIL TT,45 ;<1SQUOZE .>
JRST UNSQZ3
CAIL TT,13 ;<1SQUOZ A> IS 13
ADDI TT,'A-13 ;CONVERT RANGE A - Z ,
CAIGE TT,13 ;<1SQUOZ 1> IS 1
ADDI TT,'0-1 ;CONVERT RANGE 0 - 9
UNSQZ2: IOR TT,LD6BIT
ROT TT,-6
MOVEM TT,LD6BIT
JUMPN T,UNSQZ1
MOVE A,[440600,,LD6BIT] ;MAKE SIXBIT INTO AN ATOM
JRST READ6C
UNSQZ3: SUBI TT,46-'$ ;[1SQUOZ $] IS 46, [1SQOZ .] IS 45
CAIN TT,45-<46-'$> ;CONVERT RANGE $ - %
MOVEI TT,'* ;BUT . IS EXCEPTIONAL
JRST UNSQZ2
;GETDD0 GETDD1 PUTDDTSYM PUTDD0 PUTDD2 PUTDD4
20$ WARN [GETDD0 - CAN WE DEPEND UOPN .JBSYM ?]
IFE ITS,[
GETDD0: SKIPA D,.JBSYM" ;FIND SYMBOL IN JOB SYMBOL TABLE
GETDD1: ADD D,R70+2 ;SKIP IF FOUND
JUMPGE D,CPOPJ
MOVE T,(D)
TLZ T,540000
TLZN T,200000 ;SYMBOL MUSTN'T BE KILLED
CAME T,TT ;MUST BE THE ONE WE WANT
JRST GETDD1
MOVE TT,1(D)
AOJA D,POPJ1
] ;END OF IFE ITS
PUTDDTSYM:
MOVEI R,0 ;PUTDDTSYM| IS FOR LAP - OFFSETS VALUE BY LOAD OFFSET
PUTDD0:
IT$ JSP T,SIDDTP ;LOSE IF NO DDT TO GIVE SYMBOL TO
10$ SKIPN .JBSYM"
20$ WARN [PUTDD0 - WHAT TO DO FOR TWENEX "PUTDDTSYM"]
JRST FALSE
IFE D20,[
PUSH FXP,R
PUSH P,B
10$ SKIPL R ;SEE LDPUT1
PUSHJ P,RSQUEEZE ;SQUEEZE ATOM'S PNAME DOWN TO SQOUZE CODE
POP P,B
PUSHJ P,GETDDI
SKIPA D,.
TDZA D,D
IT$ .BREAK 12,[3,,D]
IT% JFCL ;NEEDED FOR SKIPPING OVER
POP FXP,R
JUMPE D,FALSE
IFE ITS,[
PUSHJ P,GETDD0
JRST PUTDD4
MOVEI F,(D)
] ;END OF IFE ITS
PUTDD2: JSP T,FXNV2 ;GET VALUE OF SECOND ARG
ADDI D,(R) ;ADD IN OFFSET
IT$ .BREAK 12,[400004,,TT]
10$ MOVEM D,(F)
JRST TRUE
IFE ITS,[
PUTDD4: SOSGE SYMLO
JRST FALSE
MOVE F,R70+2
SUBB F,.JBSYM"
TLO TT,100000 ;LOCAL SYMBOL
MOVEM TT,(F)
AOJA F,PUTDD2
] ;END OF IFE ITS
] ;END OF IFE D20
;LAPSETUP LAP5HAK L5H1 L5H2 L5XIT L5ERSTP L5SPBND L5H3 L5MKUNBD L5INHIBIT L50.0P L5NILP LAPSMH LAPSM1 LAPST2 LSYMPUT FSLSTP FSLST2
SUBTTL LAPSETUP AND FASLAPSETUP
LAPSETUP:
JUMPN A,LAPSMH ;ARG = NIL => SETUP SOME SYM PROPERTIES
MOVEI T,LAPST2
LAP5HAK:
PUSH P,T ;APPLIES THE ROUTINE FOUND IN T
; TO ALL THE GLOBALSYMS
PUSH P,[441100,,LAP5P] ;ATOMIC SYMBOL PLACED IN A,
; GLOBALSYM INDEX IN TT
MOVSI F,-LLSYMS
L5H1: ILDB TT,(P) ;HAFTA GET THE GLOBALSYM INDEX FROM
; PERMUTATION TABLE
CAIL TT,LGSYMS ;IF NOT A GLOBALSYM [BUT AN XTRASYM], SKIP IT
JRST L5XIT
CAIN TT,3 ;****NEVER CHANGE THE GLOBALSYM INDICES FOR:
JRST L5SPBND ; SPECBIND 3
CAIN TT,25 ; ERSETUP 25
JRST L5ERSTP ; MAKUNBOUND 34
CAIN TT,34 ; INHIBIT 47
JRST L5MKUNBD ; 0*0PUSH 53
CAIN TT,47 ; NILPROPS 54
JRST L5INHIBI ;THOSE HAVE MORE THAN 6 CHARS IN THEIR PNAME
CAIN TT,53 ;AND CANT BE RECONSTRUCTED BY UNSQOZ'ING FROM
JRST L50.0P ;FROM THE LAPFIV TABLE
CAIN TT,54
JRST L5NILP
MOVE D,LAPFIV(F)
PUSHJ P,UNSQOZ
L5H2: LDB TT,(P)
PUSHJ P,@-1(P)
L5XIT: AOBJN F,L5H1
JRST POP2J
L5ERSTP:
MOVEI A,[SIXBIT \ERSETUP \]
JRST L5H3
L5SPBND:
MOVEI A,[SIXBIT \SPECBIND \]
L5H3: HRLI A,440600
PUSHJ P,READ6C
JRST L5H2
L5MKUNBD:
MOVEI A,[SIXBIT \MAKUNBOUND \]
JRST L5H3
L5INHIBIT:
MOVEI A,[SIXBIT \INHIBIT \]
JRST L5H3
L50.0P: MOVEI A,[SIXBIT \0*0PUSH \]
JRST L5H3
L5NILP: MOVEI A,[SIXBIT \NILPROPS\]
JRST L5H3
LAPSMH: CAIE A,TRUTH ;(LAPSETUP| T 2) MEANS
JRST LAPSM1 ; SET UP THE XCT HACK AREAS
10$ JSP T,FXNV2 ; WITH 2 XCT PAGES
10$ MOVE TT,D
10$ JRST LDXHAK
10% POPJ P, ;FOR NON TOPS-10, NO NEED TO DO ANY SETUP
LAPSM1: MOVEI T,(B) ;OTHERWISE, FIRST ARG IS ADDRESS
MOVEI R,(A) ; TO HACK, SECOND NON-NIL =>
MOVE TT,(R) ; TRY THE XCT-PAGE HAK
PUSHJ P,PRCHAK ;TRY TO SMASH (SKIP ON FAILURE)
JRST TRUE
MOVEI A,(AR2A)
MOVE B,VPURCLOBRL
PUSHJ P,CONS
MOVEM A,VPURCLOBRL
JRST TRUE
LAPST2: MOVE TT,LSYMS(TT) ;GET ACTUAL VALUE FROM GLOBALSYM INDEX
MOVEI C,QSYM
LSYMPUT: ;EXPECTS SYMBOL IN A, "SYM" OR "GLOBALSYM"
MOVEI B,(A) ; IN C, AND VALUE IN TT
JSP T,FXCONS
EXCH A,B
JRST PUTPROP
FSLSTP:
MOVEI T,FSLST2
PUSHJ P,LAP5HAK
MOVE TT,LDFNM2
JRST FIX1
FSLST2: MOVEI C,(A) ;MAKE UP ATOMIC SYMBOLS AND GIVE THEM SYM PROPERTIES
JSP T,FXCONS ; OF THE FORM (0 (NIL <N>))
PUSHJ P,NCONS ; WHERE <N> IS THE INDEX OF THE SYMBOL
SETZ B, ; (THESE ARE THE "GLOBALSYMS")
PUSHJ P,XCONS
PUSHJ P,NCONS
MOVE B,CIN0
PUSHJ P,XCONS
MOVEI B,(A)
MOVEI A,(C)
MOVEI C,Q%GLOBALSYM
JRST PUTPROP
;LSYMS LGSYMS LLSYMS ZZ LAPSIX ZZ LAPFIV LAP5P GETDDTSYM GETDDI LGTSPC PAGEBPORG PGBP4
R70 ;GLOBALSYM NUMBER -1
LSYMS: GLBSYM A
LGSYMS==.-LSYMS ;END OF GLOBALSYMS HACKED BY FASLAP
XTRSYM A
LLSYMS==.-LSYMS ;END OF ALL GLOBAL SYMBOLS
;;; SIXBIT FOR LAP SYMBOL NAMES; MUST MATCH IRP LIST OF GLBSYM
ZZ==0
LAPSIX: .BYTE 6
SIXSYM [
IRPC Q,,[A]
'Q
TERMIN
0
ZZ==ZZ+1
] ;END OF SIXSYM ARGUMENT
.BYTE
IFN ZZ-LGSYMS, WARN [LAPSIX OUT OF PHASE]
EXPUNGE ZZ
LAPFIV:
GLBSYM [SQUOZE 0,A]
XTRSYM [SQUOZE 0,A]
HAOLNG LOG2LL5,<LLSYMS-1> ;CROCK FOR BINARY SEARCH
REPEAT <1←LOG2LL5>-LLSYMS, 377777,,777777
LAP5P: BLOCK <LLSYMS+3>/4 ;PERMUTATION, STORED 4/WD, TO GET GLOBALSYMINDEX FROM LAPFIV INDEX
GETDDTSYM:
PUSHJ P,RSQUEEZE
PUSHJ P,GETDDI
JRST FIX1
20$ WARN [DEC20 GETDDTSYM?]
IFE ITS+D10, JRST FALSE
IFN ITS+D10,[
IT$ MOVE D,TT ;SAVE SQUOZE OVER CALL TO SIDDTP
IT$ JSP T,SIDDTP ;LOSE IF NO DDT FROM WHICH TO GET SYMBOL
10$ SKIPN .JBSYM" ;LOSE IF NO JOB SYMBOL TABLE
JRST FALSE
IT$ MOVE TT,D
IT$ .BREAK 12,[4,,TT]
IT$ JUMPE TT,FALSE
IT$ MOVE TT,TT+1
10$ PUSHJ P,GETDD0
10$ JRST FALSE
JRST FIX1
] ;END OF IFN ITS+D10
GETDDI: MOVEI R,0 ;SEARCH INTERNAL TABLE, SKIP IF LOSE
IT$ MOVE T,TT
TLZ T,740000 ; LEAVE VALUE IN TT IF WIN
REPEAT LOG2LL5,[
CAML T,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
ADDI R,1←<LOG2LL5-.RPCNT-1>
] ;END OF REPEAT LOG2LL5
CAME T,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST POPJ1 ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F) ;USE TABLE FROM FASLOAD
MOVE TT,LSYMS(TT)
POPJ P,
LGTSPC: MOVEM TT,GAMNT
ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT)
SUB TT,@VBPEND
JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE.
MOVE A,VBPEND ;ALREADY OK
MOVE TT,(A)
POPJ P,
PAGEBPORG: MOVE A,VBPORG ;MAKE SURE BPORG IS ON PAGE BOUNDRY
MOVE TT,(A) ;NUMERIC VALUE OF BPORG
TRNN TT,PAGKSM
POPJ P,
ADDI TT,PAGSIZ-1
ANDCMI TT,PAGKSM
CAMGE TT,@VBPEND
JRST PGBP4
PUSH FXP,TT ;NEW VALUE FOR BPORG
JSP T,SPECBIND
0 VNORET
AOS VNORET
PUSH P,CUNBIND
SUB TT,(A)
PUSHJ P,LGTSPC
JUMPE TT,[LERR [SIXBIT \NO CORE - PAGEBPORG!\]]
POP FXP,TT
PGBP4: JSP T,FIX1A
MOVEM A,VBPORG ;GIVE BPORG NEW PAGIFIED VALUE
POPJ P,
;MAKUBE MAKUNBOUND MAKUN1
SUBTTL MAKUNBOUND
;NEVER FLUSHES VALUE CELL
MAKUBE: %WTA [SIXBIT \UNCHANGEABLE VALUE - MAKUNBOUND!\]
MAKUNBOUND: ;SUBR 1 - FLUSH VALUE OF ATOMIC SYMBOL
BAKPRO
JSP D,SETCK ;MAKE SURE IT'S A SYMBOL
JUMPE A,MAKUBE
CAIN A,TRUTH
JRST MAKUBE
HLRZ T,(A)
MOVE B,(T)
IFE 0, NOPRO
IFN 0,[
TLNE B,300 ;CAN'T RECLAIM VALUE CELL IF PURE
JRST MAKUN1 ; OR IF COMPILED CODE NEEDS IT
TLZ B,-1
CAIN B,SUNBOUND ;CAN'T RECLAIM SUNBOUND!!!
POPJ P,
CAIL B,BXVCSG+NXVCSG*SEGSIZ
JRST MAKUN1 ;CAN'T RECLAIM CELL NOT IN VALUE CELL AREA
EXCH B,FFVC ;SO RECLAIM THE VALUE CELL ALREADY
XCTPRO
MOVEM B,@FFVC
MOVEI B,SUNBOUND ;USE SUNBOUND FOR A VALUE CELL
HRRM B,(T)
NOPRO
POPJ P, ;THAT'S ALL
] ;END IFN 0
MAKUN1: PUSH P,A ;MAKE SURE WE RETURN THE ARGUMENT
PUSH P,CPOPAJ
MOVEI B,QUNBOUND ;FALL INTO SET WITH "UNBOUND" VALUE
JRST SET+1
;$PURIFY FPURF0 FPURF7 FPURF1 FPUR1Q FPUR1A FPURF4 FPURF3
IFN USELESS,[
SUBTTL PURIFICATION RITES
$PURIFY:
IFN D10, POPJ P,
IFN ITS+D20,[
LOCKTOPOPJ
SETZ AR1,
JSP T,FXNV1 ;GET TWO MACHINE NUMBERS
JSP T,FXNV2
ANDCMI TT,1777 ;PAGIFY FIRST DOWNWARD
IORI D,1777 ;PAGIFY SECOND UPWARD
CAMLE TT,D
LERR [SIXBIT \ARG 2 < ARG 1 - PURIFY!\]
JUMPE C,FPURF3 ;NULL THIRD ARG MEANS DEPURE
MOVE T,LDXLPL
HRRZ T,LDXPSP(T) ;GET ADR OF POSSIBLY PURE PAGE
CAIG TT,(T)
CAIGE D,(T)
SKIPA
SETZM LDXLPC ;FOR PURE PAGE JUST FORCE FREE COUNT TO ZERO
FPURF0: CAIE C,QBPORG
JRST FPURF3
.SEE PURIFY ;PURIFY ENTERS HERE
FPURF7: MOVSI F,2000 ;THIS BIT CONVERTS CALL TO CALLF, JCALL TO JCALLF
MOVEI T,VPURCL
PUSH P,T
FPURF1: HRRZ T,(T) ;CDR DOWN THE PURLIST
FPUR1Q: JUMPE T,FPURF2
FPUR1A: HLRZ AR2A,(T)
PUSHJ P,LDSMSH ;TRY TO SMASH
JRST FPURF4 ;WIN
IORM F,(AR2A) ;LOSE - MAKE IT A CALLF/JCALLF
FPURF4: HRRZ T,@(P) ;WIN, SO CUT IT OUT OF PURCLOBRL
HRRZ T,(T)
HRRM T,@(P)
JRST FPUR1Q
FPURF3: JSP R,IP0
POPJ P,
] ;END OF IFN ITS+D20
;IP0 IP7 IP7 IP1
;;; IFN USELESS
IP0: ;PURIFY/DEPURIFY SOME PAGES
IFN D10, JRST (R) ;C HAS FLAG, NON-NULL MEANS PURIFY
IFN D20+ITS,[
LSH D,-PAGLOG ;CALLED BY JSP R,IP0
LSH TT,-PAGLOG ;USES B,C,T,TT,D,F
CAIGE TT,1
LERR [SIXBIT \1ST PAGE NOT PURE!\]
MOVEI B,(TT) ;FIGURE OUT PURTBL BYTE POINTER
IFN ITS,[
ROT B,-4
ADDI B,(B)
ROT B,-1
TLC B,770000
ADD B,[450200,,PURTBL]
SUBI D,-1(TT) ;CALCULATE NUMBER OF PAGES
IMULI TT,1001
TRO TT,400000 ;SET UP ARG FOR .CBLK20$ MOVSI 1,.FHSLF
SKIPN C
TLOA TT,400
SKIPA C,R70+2 ;IN PURTBL, 1=IMPURE, 2=PURE
MOVEI C,1
IP7: .CBLK TT, ;HACK PAGE
JSP F,IP1 ;IP1 HANDLES LOSSES
ADDI TT,1001
] ;END OF IFN ITS
IFN D20,[
ROT TT,-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[450200,,PURTBL]
SUBI D,-1(B) ;CALCULATE NUMBER OF PAGES
HRRI 1,(TT)
HRLI 1,.FHSLF
MOVSI 2,(PA%RD+PA%EX)
SKIPN C
TLOA 3,(PA%CPY)
SKIPA F,R70+2
MOVEI F,1
IP7: SPACS
ADDI 1,1
ADDI 2,1
] ;END OF IFN D20
TLNN B,730000 ;FOR BIBOP, DEPOSIT BYTE IN PURTBL
TLZ B,770000
IT$ IDPB C,B
20$ IDPB F,TT
SOJN D,IP7
JRST (R)
IFN ITS,[
IP1: MOVE T,[4400,,<776000+<SFA*1000>>];ASSUME FAILURE WAS DUE TO SHARING
.CBLK T, ;USES ONLY T,TT
.LOSE 1000+%ENACR ;NO CORE AVAILABLE
LDB T,[111000,,TT]
LSH T,PAGLOG+22
HRRI T,<376+SFA>*PAGSIZ ;SO COPY PAGE INTO SOME FAKE PAGE
BLT T,<376+SFA>*PAGSIZ+1777 ;LIKE PAGE NUMBER 376
MOVE T,TT
ANDCMI T,377
IORI T,376+SFA
.CBLK T, ;MOVE PAGE MAP FOR 376 INTO LOSING PAGE POSITION
.LOSE
MOVEI T,376000+<SFA*1000>
.CBLK T, ;FLUSH ENTRY FOR PAGE 376
.LOSE
JRST (F)
] ;END OF IFN ITS
] ;END OF IFN ITS+D20
] ;END OF IFN USELESS
;GOINIT GOINI7
SUBTTL 100$G RESETS THE WORLD!
GOINIT:
IT$ .SUSET [.S40ADDR,,[TWENTY,,FORTY]] ;SET .40ADDR
MOVEI A,READTABLE
MOVEM A,VREADTABLE
IFN USELESS,[
MOVE A,[RCT0,,RCT]
BLT A,RCT+LRCT-1 ;RESTORE READ CHARACTER SYNTAX TABLE
] ;END OF IFN USELESS
MOVEI A,TTYIFA
MOVEM A,V%TYI
MOVEI A,TTYOFA
MOVEM A,V%TYO
MOVEI A,TRUTH
MOVEM A,VINFILE
SETZM VINSTACK
SETZM VOUTFILES
SETZM VECHOFILES
MOVEI A,QTLIST
MOVEM A,VMSGFILES
IFN USELESS&ITS,[
MOVEI T,IB<MAR> ;RESET THE MAR BREAK FEATURE
ANDCAM T,IMASK
.SUSET [.SAMASK,,T]
.SUSET [.SMARA,,R70]
] ;END OF IFN USELESS
MOVEI A,OBARRAY
MOVEM A,VOBARRAY ;GET BACK TOPLEVEL OBARRAY
SETZM V%PR1
SETZM VOREAD
SETZM TLF
SETZM BLF ;??
SETZM UNRC.G ;CLEAR STACKED NOINTERRUPT STUFF
SETZM UNRRUN
SETZM UNRTIM
SETZM UNREAR
SETZM TTYOFF
JSP A,ERINIT
GOINI7: SETZB A,VERRLI ;NULLIFY ERRLIST
PUSHJ P,INTERN
JUMPE A,LISPGO
PUSHJ P,REMOB2 ;GET STANDARD COPY OF NIL ON OBLIST
JRST GOINI7
PGTOP UIO,[UTAPE, LAP, AND AGGLOMERATED SUBRS]
;ZEROP MINUSP PLUSP ZMP MINUS MNSFX
;;@ END OF ULAP 133
;;@ ARITH 78 STANDARD ARITHMETIC FUNCTIONS
;;; ***** MACLISP ****** STANDARD ARITHMETIC FUNCTIONS ***********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1978 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT ARI
;THE ARITHMETIC PAGE - ARITHMETIC SUBROUTINES
IFN BIGNUM,[
SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==1
ZEROP: MOVEI R,2
JRST ZMP
MINUSP: TDZA R,R
PLUSP: MOVEI R,1
ZMP: JSP T,NVSKIP
JRST .+2
JFCL
XCT .+2(R)
JRST FALSE
JUMPL TT,TRUE ;FOR MINUSP
JUMPG TT,TRUE ;FOR PLUSP
JUMPE TT,TRUE ;FOR ZEROP
MINUS: JSP T,NVSKIP
JRST MNSBG
JRST MNSFX
MOVNS TT
JRST FLOAT1
MNSFX: CAMN TT,[400000000000]
JRST ABSOV
MOVNS TT
JRST FIX1
;ADD1 SUB1 SUB11 A1S1FX A1S11 A1S1BG ABSOV
ADD1: MOVEI R,1
JRST SUB11
SUB1: MOVNI R,1
SUB11: JSP T,NVSKIP
JRST A1S1BG
JRST A1S1FX
JUMPL R,.+3
FAD TT,[1.0]
JRST FLOAT1
FSB TT,[1.0]
JRST FLOAT1
A1S1FX: CAMN TT,[1←43]
JUMPL R,A1S11
ADD TT,R
CAMN TT,[1←43] ;DONT WANT TO GET -2E35. BY ADD1
JUMPG R,ABSOV
JRST FIX1
A1S11: PUSHJ P,ABSOV ;CANT SUB1 FROM -2E35. AND
HRROS (A)
A1S1BG: PUSH P,B ;ADD1 AND SUB1 FOR BIGNUM
PUSH P,CPOPBJ
MOVEI B,IN1
JUMPL R,.DIF
JRST .PLUS
ABSOV: PUSH P,B ;OVERFLOW FROM ADD1, SUB1, ABS,
MOVEI TT,1 ; MINUS, HAIPART, GCD, ETC.
PUSHJ P,C1CONS
MOVE B,A
MOVEI TT,0
PUSHJ P,C1CONS
HRRM B,(A)
PUSHJ P,BNCONS
JRST POPBJ
;COMPR DIFFA PLUSA TIMESA QUOA QUOOV QUOAK QUOAK2 QUOAK1
;;; MOBY DISPATCH TABLES FOR THE VARIOUS ARITHMETIC OPERATIONS
CAIA
. ;UNUSED WORD
JRST GRSWF
COMPR: JRST GRSWX
JFCL 0
JRST GRBFX
JRST GRFXB
JRST GRBB
SKIPE VZFUZZ
0
FSBR D,TT
DIFFA: SUB D,TT
JRST PLOV
JRST PL2BN
JRST PL1BN
JRST BNDF
SKIPE VZFUZZ ;-3(R) SKIP UNLESS FUZZ HACK TO BE PULLED
0 ;-2(R) OPERATION IDENTITY - VALUE WHEN NO ARGS GIVEN
FADR D,TT ;-1(R) FLOATING POINT INSTRUCTION FOR OPERATION
PLUSA: ADD D,TT ;0(R) FIXED POINT INSTRUCTION FOR OPERATION
JRST PLOV ;1(R) ACTION ON ARITHMETIC OVERFLOW
JRST PL2BN ;2(R) BIGNUMBER ACCUMULATION MEETS FIXNUM ARG
JRST PL1BN ;3(R) FIXNUM ACCUMULATION MEETS BIGNUM ARG
JRST BNPL ;4(R) BIGNUM ACCUMULATION, BIGNUM ARG
CAIA
1
FMPR D,TT
TIMESA: IMUL D,TT
JRST TIMOV
JRST TIM2BN
JRST TIM1BN
JRST BNTIM
CAIA
1
FDVR D,TT
QUOA: JRST QUOAK
JRST QUOOV
JRST DV2BN
JRST DV1BN
JRST BNDV
QUOOV: SKIPN RWG
JRST OVFLER
AOS D,T
JFCL 8.,PLOV
JRST T14E
QUOAK: CAMN D,[400000,,0] ;ORDINARY FIXED POINT DIVISION
JRST QUOAK1 ;DOESN'T ALWAYS WIN ON SETZ
QUOAK2: IDIVM D,TT
MOVE D,TT
JRST T14EX2
QUOAK1: CAMN TT,XC-1 ;SETZ/(-1) => POSITIVE SETZ
JRST DIVSEZ
CAIN TT,1 ;SETZ/1 => SETZ
JRST T14EX2
JRST QUOAK2 ;IDIVM WORKS FOR OTHER CASES
;T1 .QUO .TIMES .DIF .PLUS T21 QUOTIENT TIMES DIFFERENCE PLUS T22 T20 T24 T4 T7 T7A T7X T7X1 T7O ZFZCHK ZFZCH9
T1: JUMPE T,NMCK0 ;ONLY ONE ARG GIVEN - GIVE IT OUT
MOVE TT,-2(R) ;NO ARGS GIVEN - GIVE OUT OPERATORS IDENTITY
JRST FIX1
.QUO: SKIPA R,[QUOA] ;C KEEPS ADDRESS OF FUNCTION TYPE
.TIMES: MOVEI R,TIMESA
SETZM REMFL
JRST T21
.DIF: SKIPA R,[DIFFA]
.PLUS: MOVEI R,PLUSA
T21: MOVNI T,1
PUSH P,A
PUSH P,B
JRST T20
QUOTIENT: SKIPA R,[QUOA]
TIMES: MOVEI R,TIMESA
SETZM REMFL
JRST T22
DIFFERENCE: SKIPA R,[DIFFA]
PLUS: MOVEI R,PLUSA
T22: AOJGE T,T1
T20: MOVE F,T ;D - ACCUMULATED VALUE
ADDI F,1(P) ;TT - NEXT VALUE IN LINE
HRL F,T
T24: MOVNI T,-1(T)
HRLS T ;R - ADDRESS OF INSTRUCTION DISPATCH TABLE
MOVEM T,PLUS8 ;F - AOBJN POINTER TO ARG VECTOR ON PDL
MOVE A,-1(F)
JSP T,NVSKIP ;PICK UP FIRST ARG AND DISPATCH TO APPROPRIATE LOOP
JRST T2
JRST T3
MOVE D,TT
JRST 2,@[.+1]
T4: MOVE A,(F) ;FLOATING POINT ARITHMETIC LOOP
JSP T,NVSKIP
JRST T6
JRST T5
T7: XCT -1(R) ;FLOATING SUM OPERATED WITH FLOATING NEXT ARG
XCT -3(R) ;SKIP UNLESS ZFUZZ HACK REQUIRED
JSP A,ZFZCHK
T7A: AOBJN F,T4
JFCL 8.,T7O
T7X: MOVE TT,D ;EXIT ARITHMETIC LOOP WITH ACCUMULATED VALUE
T7X1: SUB P,PLUS8
JRST FLOAT1
T7O: JSP T,T7O0
JRST T7X1
ZFZCHK: MOVE T,D
JRST 2,@[.+1]
FDVR T,TT
JFCL 8,ZFZCH9
MOVM T,T
CAMGE T,@VZFUZZ
SETZ D,
ZFZCH9: JRST 2,(A) ;DON'T LET FDVR AFFECT OVERFLOW/UNDERFLOW
;T5 T6 T6A T3 T15 T14 T14EX2 T14E T14EX T14EX1 ABS
;;; IFN BIGNUM ;ARITH OPS FOR BIGNUM==1 CONTINUED
T5: EXCH D,AGDBT
JSP T,IFLOAT ;FLOATING SUM, NEXT IS FIXED POINT
EXCH D,AGDBT
JRST T7
T6: CAIN R,QUOA
JRST T6A
PUSHJ P,FLBIG ;FLOATING SUM, NEXT WAS BIGNUM
JRST T7
T6A: PUSHJ P,FLBIGQ ;SPECIAL HACK FOR JPG
JRST T7
SETZ D, ;IF BIGNUM TOO LARGE, WE GET
JRST T7A ; UNDERFLOW, NOT OVERFLOW
T3: MOVE D,TT ;FIXED POINT ARITHMETIC LOOP
JRST 2,@[.+1]
T15: MOVE A,(F)
JSP T,NVSKIP
XCT 3(R) ;DISPATCH TO CONVERT SUM TO BIGNUM
JRST T14 ;OPERATE ON TWO FIXED POINT
MOVEM TT,AGDBT
MOVE TT,D ;FIXED POINT SUM CONVERTED TO FLOATING
JSP T,IFLOAT ;AND ENTER FLOATING LOOP
MOVE D,TT
MOVE TT,AGDBT
JRST T7 ;IFLOAT CANNOT HAVE SET OFVLO FLG
T14: MOVE T,D ;SAVE OLD SUM, JUST INCASE THERE IS OVERFLO
XCT 0(R) ;OPERATE FIXED POINT
T14EX2: JFCL 8,1(R) ;CHECK FOR OVERFLO, IF SO DISPATCH TO BIGNUM
T14E: AOBJN F,T15
T14EX: MOVE TT,D
T14EX1: SUB P,PLUS8
JRST FIX1
ABS: JSP T,NVSKIP
JRST ABSBG
SKIPA T,CFIX1
MOVEI T,FLOAT1
JUMPGE TT,PDLNMK
CAMN TT,[1←43] ;ABS OF -2**35. IS NO LONGER FIXNUM
JRST ABSOV
MOVMS TT
JRST (T)
;REMAINDER REMAI2 FLOAT FIX4 FLOAT4 $IFIX FIX FIX25
REMAINDER: SETZB F,PLUS8
JSP T,NVSKIP
JRST REMBIG ;BIGNUM
SKIPA D,TT
JSP T,REMAIR ;FLONUM IS ERROR - RETURNS TO THE NVSKIP
EXCH A,B ;FIRST ARG IS FIXNUM
JSP T,NVSKIP
JRST REMAI2 ;IF SECOND IS BIGNUM NOW, MAYBE GIVE OUT FIRST
SKIPA T,D
JSP T,REMAIR ;FLONUM IS ERROR
JUMPE TT,BPDLNKJ
MOVE D,TT
SETZ TT, ;IN THE CASE OF (\ SETZ 1), TRY TO WIN
IDIV T,D
JRST FIX1
REMAI2: SKIPL T,(B) ;WELL, IF FIRST ARG IS SETZ, AND
JRST BPDLNKJ ; SECOND ARG IS +SETZ, THEN REMAINDER
CAME T,[400000,,] ; SHOULD BE 0, NOT SETZ!
JRST BPDLNKJ
MOVE A,(A)
PUSH P,AR1 ;MUST SAVE AR1
PUSHJ P,BNTRS1 ;SKIPS 2 UNLESS BIGNUM IS
POP P,AR1 ; +SETZ (OR SETZ)
JRST 0POPJ
POP P,AR1
JRST BPDLNKJ
FLOAT: TDZA R,R
MOVEI R,TRUTH
JSP T,NVSKIP
JRST FLBIGF
JRST FLOAT4
FIX4: JUMPE R,PDLNKJ ;ARG IS ALREADY OF REQUIRED TYPE. IF "CALL"ED, THEN RETURN LISP ANSWER IN A
POPJ P, ;ELSE IF "NCALL"ED, RETURN NUMERIC ANSWER IN TT
FLOAT4: JSP T,IFLOAT
JUMPE R,FLOAT1
POPJ P,
$IFIX: TDZA R,R
MOVEI R,TRUTH
JSP T,FLTSKP
JRST FIX4
JRST FIX25
FIX: TDZA R,R
MOVEI R,TRUTH
JSP T,NVSKIP
POPJ P,
JRST FIX4
FIX25: MOVM T,TT
CAML T,[244000,,]
JRST FIXBIG
JSP T,IFIX
JUMPE R,FIX1
POPJ P,
;.GREAT .LESS LESSP GREATERP GTR1 GTR9 MIN MAX MXF MXS MAXFIN MAX923
.GREAT: EXCH A,B
.LESS: PUSH P,A
PUSH P,B
MOVNI T,2
LESSP: SKIPA A,[CAML D,2]
GREATERP: HRLZI A,(CAMG D,)
MOVEI D,GRFAIL
MOVEI R,GRSUCE
GTR1: MOVE F,T
AOJGE T,GTR9
HRRI A,TT
ADDI F,2(P)
HRLI F,(T)
PUSHJ FXP,SAV5M2
HRLI D,(JRST)
MOVEM D,CFAIL
HRLI R,(JRST)
MOVEM R,CSUCE
MOVEI R,COMPR
MOVEM A,GRESS0
JRST T24
GTR9: MOVEI D,QMAX+1(A)
SOJA T,WNALOSS
MIN: SKIPA A,[CAML D,1]
MAX: HRLOI A,(CAMG D,)
AOJE T,NMCK0
MOVEI D,MXF
MOVEI R,MXS
SOJA T,GTR1
MXF: MOVE AR1,AR2A
SKIPA D,TT
MXS: MOVE AR2A,AR1
AOBJN F,GRSUC1
MAXFIN: MOVEI B,(AR1)
PUSHJ FXP,RST5M2
2DIF JRST @(B),MAX923,QFIXNUM
MAX923: T14EX ;FIXNUM
T7X ;FLONUM
T13X ;BIGNUM
;GRSUC2 GRSUC1 GRS923 GRSUCE GRSFIN GRSF1 GRFAIL GRSWF GRSWX
GRSUC2: MOVE D,TT
GRSUC1:
2DIF JRST @(AR2A),GRS923,QFIXNUM
GRS923: T15 ;FIXNUM
T4 ;FLONUM
T12 ;BIGNUM
GRSUCE: AOBJN F,GRSUC2
GRSFIN: MOVEI A,TRUTH
GRSF1: PUSHJ FXP,RST5M2
SUB P,PLUS8
POPJ P,
GRFAIL: MOVEI A,NIL
JRST GRSF1
GRSWF: SKIPA AR1,[QFLONUM]
GRSWX: MOVEI AR1,QFIXNUM
MOVE AR2A,AR1
JRST GRESS0
] ;END OF ARITH OPS WITH BIGNUM==1
;ADD1 SUB1 REMAINDER MINUS ABS MINUSP PLUSP ZEROP
IFE BIGNUM,[
SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==0
ADD1: JSP T,FLTSKP
AOJA TT,FIX1
FAD TT,[1.0]
JRST FLOAT1
SUB1: JSP T,FLTSKP
SOJA TT,FIX1
FSB TT,[1.0]
JRST FLOAT1
REMAINDER: JSP T,FXNV1
JSP T,FXNV2
IDIV TT,TT+1
MOVE TT,TT+1
JRST FIX1
MINUS: JSP T,FLTSKP
SKIPA T,CFIX1
MOVEI T,FLOAT1
MOVNS TT
JRST (T)
ABS: JSP T,FLTSKP
SKIPA T,CFIX1
MOVEI T,FLOAT1
MOVMS TT
JRST (T)
MINUSP: SKIPA R,[JUMPGE TT,FALSE]
PLUSP: MOVE R,[JUMPLE TT,FALSE]
JSP T,FLTSKP
JFCL
XCT R
JRST TRUE
ZEROP: JSP T,FLTSKP
JFCL
JUMPE TT,TRUE
JRST FALSE
;$IFIX FIX FIX4 FLOAT FIXFLO FLOAT3
$IFIX:
FIX: TDZA R,R
MOVEI R,TRUTH
JSP T,FIXFLO
TLNN T,FL ;FIXFLO LEFT TYPE BITS IN T
JRST FIX4
JSP T,IFIX
JUMPE R,FIX1
POPJ P,
FIX4: JUMPE R,PDLNKJ
POPJ P,
FLOAT: TDZA R,R
MOVEI R,TRUTH
JSP T,FIXFLO
TLNN T,FX ;FIXFLO LEFT TYPE BITS IN T
JRST FIX4
JSP T,IFLOAT
JUMPE R,FLOAT1
POPJ P,
FIXFLO: PUSH P,A
LSH A,-SEGLOG
HLL T,ST(A) ;LEAVES TYPE BITS IN T
TLNN T,FX+FL
JRST FLOAT3
POP P,A
MOVE TT,(A)
JRST (T)
FLOAT3: POP P,A
%WTA NMV3
JRST FIXFLO
;MIN MAX MINMAX .GREAT .LESS LESSP GREATERP MNMX1 MNMX9 GRESS GRUSE
MIN: SKIPA A,[CAMLE F,1]
MAX: HRLOI A,(CAMGE F,)
AOJE T,NMCK0
MOVEI D,MINMAX
SOJA T,MNMX1
MINMAX: XCT MNMX0 ;CAMG F,TT OR CAML F,TT
MOVE F,TT
JRST PLUS4
.GREAT: EXCH A,B
.LESS: PUSH P,A
PUSH P,B
MOVNI T,2
LESSP: SKIPA A,[CAML F,2]
GREATERP:
HRLZI A,(CAMG F,)
MOVEI D,GRESS
MNMX1: HRLI D,(JRST)
MOVEM D,PLUS3
MOVNM T,PLUS8
MOVE R,T
AOJGE T,MNMX9
HRRI A,TT
MOVEM A,GRESS0 ;THIS IS ALSO MNMX0
ADD R,P
MOVE A,1(R)
SETOM PLUS0
JSP T,FLTSKP
SETZM PLUS0
MOVE F,TT
AOJA R,PLUS7
MNMX9: MOVEI D,QMAX+1(A)
SOJA T,WNALOSS
GRESS: XCT GRESS0
JRST GRUSE
MOVE F,TT
CAME P,R
JRST PLUS9
SUB P,PLUS8
JRST TRUE
GRUSE: SUB P,PLUS8
JRST FALSE
;.DIF DIFFERENCE DIF2 .QUO QUOTIENT QUO2 QUO3
.DIF: PUSH P,A
PUSH P,B
MOVNI T,2
DIFFERENCE: MOVE R,[JRST DIF2]
MOVE D,R
SOJA D,DIF1
SKIPA D,[FSBR F,TT]
DIF2: MOVE D,[SUB F,TT]
MOVEM D,PLUS3
MOVE D,[FSBR F,TT]
MOVEM D,PLUS6
MOVE F,TT
JRST PLUS4
.QUO: PUSH P,A
PUSH P,B
MOVNI T,2
QUOTIENT: MOVE R,[JRST QUO2]
MOVE D,R
SOJA D,QUO1
SKIPA D,[FDVR F,TT]
QUO2: MOVE D,[JRST QUO3]
MOVEM D,PLUS3
MOVE D,[FDVR F,TT]
MOVEM D,PLUS6
MOVE F,TT
JRST PLUS4
QUO3: CAIN TT,1
CAME F,[400000,,0]
CAIA
SKIPA TT,F
IDIVM F,TT
EXCH F,TT ;ALL THIS LOSSAGE SO THAT F+1 WONT BE DISTURBED
JFCL 8.,.+2
JRST PLUS4
SKIPN RWG
JRST OVFLER
SKIPGE TT
SOSA F,TT
AOS F,TT
JFCL 8.,OVFLER
JRST PLUS4
;.TIMES TIMES QUO1 .PLUS PLUS DIF1 PLUS1 PLUS7 PLUS5 PLUS3A PLUS4 PLUS9 PLUS2 PLUS2A PLUS2V T7O0
.TIMES: PUSH P,A
PUSH P,B
MOVNI T,2
TIMES: MOVE R,[IMUL F,TT]
MOVE D,[FMPR F,TT]
QUO1: MOVEI F,1
JRST PLUS1
.PLUS: PUSH P,A
PUSH P,B
MOVNI T,2
PLUS: MOVE R,[ADD F,TT]
MOVE D,[FADR F,TT]
DIF1: MOVEI F,0
PLUS1: MOVNM T,PLUS8
JUMPE T,PLUS2
ADD T,P
MOVEM R,PLUS3
SETZM PLUS0
MOVE R,T
PLUS7: MOVEM D,PLUS6
HRLS PLUS8
JRST 2,@[PLUS4]
PLUS5: MOVE D,PLUS6 ;FAD F,TT OR FMP F,TT OR ETC.
MOVEM D,PLUS3
SETOM PLUS0
EXCH F,TT
JSP T,IFLOAT
EXCH F,TT
PLUS3A: XCT PLUS3
PLUS4: CAMN P,R
JRST PLUS2
PLUS9: MOVE A,1(R)
JSP T,FLTSKP
JRST .+4
SKIPE PLUS0
AOJA R,PLUS3A
AOJA R,PLUS5
SKIPE PLUS0
JSP T,IFLOAT
AOJA R,PLUS3A
PLUS2: MOVE TT,F
JFCL 8.,PLUS2V
PLUS2A: SUB P,PLUS8 ;FALL THRU TO MAKNUM
SKIPN PLUS0
JRST FIX1
JRST FLOAT1
PLUS2V: JSP T,T7O0
JRST PLUS2A
] ;END OF ARITH OPS WITH BIGNUM=0
T7O0: SKIPE VZUNDERFLOW ;NON-NIL => FLOATING UNDERFLOW
TLNN T,100 .SEE %PCFXU ; YIELDS ZERO RESULT INSTEAD OF ERROR
JRST UNOVER
MOVEI TT,0
JRST (T)
;EXPT XPTLL XPT.X XPTLX XPTLX1 XPTLX2 XPTOV
SUBTTL GENERAL EXPONENTIATION ROUTINE
EXPT: JRST 2,@[.+1] ;SUBR 2 - COMPUTE A↑B
EXCH A,B ;FIND TYPE OF EXPONENT FIRST
IFN BIGNUM,[
JSP T,NVSKIP ;EXPONENT IS . . .
JRST XPT.B ;IT'S A BIGNUM
JRST XPT.X ;IT'S A FIXNUM
EXCH A,B ;IT'S A FLONUM
JSP T,NVSKIP ;BASE IS . . .
JRST XPTBL ;BIGNUM BASE
JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT
] ;END OF IFN BIGNUM
IFE BIGNUM,[
JSP T,FLTSKP ;EXPONENT IS . . .
JRST XPT.X ;IT'S A FIXNUM
EXCH A,B ;IT'S A FLONUM
JSP T,FLTSKP ;BASE IS . . .
JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT
] ;END OF IFE BIGNUM
XPTLL: PUSH P,CFLOAT1 ;FLONUM↑FLONUM
SKIPN (B) ; X↑0.0 => 1.0
JRST 1.0PJ
JUMPE TT,CPOPJ ; 0.0↑X => 0.0
PUSHJ P,LOG.. ;SO COMPUTE FLONUM↑FLONUM BY USING THE FORMULA:
FMPR TT,(B) ; B (B LOG A)
JRST EXP.. ; A = E
XPT.X: EXCH A,B ;FIXNUM EXPONENT FOUND
MOVE D,TT
BG$ JSP T,NVSKIP ;CHECK BASE FOR FIXNUM EXPONENET
BG$ JRST XPTBX ;BIGNUM BASE
BG% JSP T,FLTSKP
JRST XPTXX0 ;FIXNUM BASE
PUSH P,CFLOAT1 ;FLONUM BASE => FLONUM RESULT
XPTLX: JSP R,XPTZL ;CHECK EASY CASES
SKIPA R,TT ;NORMAL CASE - USE THE MULTIPLY
XPTLX1: FMPR R,R ; AND SQUARE HACK
TRNE D,1
FMPR T,R
JFCL 8,XPTOV ;CHECK FOR OVERFLOW
LSH D,-1
JUMPN D,XPTLX1
XPTLX2: MOVE TT,T ;ANSWER GOES IN TT
POPJ P,
XPTOV: JSP T,T7O0
POPJ P,
;XPTXX0 XPTXX XPTXX5 XPTXX3 XPTXX4 2XPT 2BGXPT 2BGXP1
XPTXX0: PUSHJ P,XPTXX
JRST FIX1
POPJ P,
;;; SKIPS IF ANSWER IS A BIGNUM
XPTXX: JSP R,XPTZX ;FIXNUM↑FIXNUM - CHECK EASY CASES
JUMPL D,ZPOPJ
IFE BIGNUM,[
SKIPA R,TT
XPTXX5: IMUL R,R
TRNE D,1
IMUL T,R
LSH D,-1
JUMPN D,XPTXX5
MOVE TT,T
JFCL 8,XPTOV
POPJ P,
] ;END OF IFE BIGNUM
IFN BIGNUM,[
SKIPGE R,TT
JRST XPTXX3
JFFO R,.+1
LSH R,1(F)
JUMPE R,2XPT ;XPTZX HAS CHECKED BASE, SO IT'S NOT 0/1/-1
MOVE R,TT
XPTXX3: MOVE TT,T ;HERE YOU GO FANS, YOU BASIC MULTIPLY BY SQUARING LOOP.
MOVEM D,NORMF
TRNE D,1
IMUL T,R
JFCL 8.,EXPT6C
LSH D,-1
JUMPN D,XPTXX4
MOVE TT,T
POPJ P,
XPTXX4: MOVE F,R
IMUL R,R
JFCL 8.,EXPT6B
JRST XPTXX3
2XPT: MOVNI F,(F)
IMULI D,36.-1(F)
MOVEI TT,1
CAIL D,35.
JRST 2BGXPT
ASH TT,(D)
POPJ P,
2BGXPT: IDIVI D,35.
ASH TT,(R)
JSP T,FIX1A
PUSHJ P,NCONS
2BGXP1: MOVE B,CIN0
PUSHJ P,XCONS
SOJG D,2BGXP1
PUSHJ P,BGNMAK
JRST POPJ1
] ;END OF IFN BIGNUM
;XPTBL XPT.B XPTZX0 EXPT6B EXPT6C EXPT1A EXPT1 EXPT3 EXPT2 EXPT4 XPTBX XPTBX1
IFN BIGNUM,[
XPTBL: PUSH P,A ;BIGNUM↑FLONUM
PUSHJ P,FLBIG ;SO FLOAT THE BIGNUM, THEN USE
SUB P,R70+1 ; FLONUM↑FLONUM
JRST XPTLL
XPT.B: EXCH A,B ;BIGNUM FOUND AS EXPONENT
HLRZ D,(TT)
HRRZ D,(D)
TLNE TT,400000
TLO D,400000 ;D GETS SIGN-BIT IN 4.9, RANDOM-NON-ZERO-BIT IN 3.1
TLO D,1 ;AND ODDP-BIT IN 1.1
JSP T,NVSKIP
JRST OVFLER
JRST XPTZX0
PUSH P,CFLOAT1
JSP R,XPTZL ;FLONUM↑BIGNUM -- CHECK EASY CASES
MOVMS TT
CAML TT,T ;T SUPPOSED TO HAVE 1.0
JRST OVFLER
SKIPN VZUNDERFLOW
JRST UNFLER
JRST ZPOPJ ;PUTS A RANDOM ZERO IN TT, AND POPJS
XPTZX0: PUSH P,CFIX1
JSP R,XPTZX ;FIXNUM↑BIGNUM -- CHECK EASY CASES
JUMPL D,ZPOPJ ;N↑-<M> ==> 0
JRST OVFLER
;;; MUST SKIP 1 AS POPJ SINCE ONLY COME HERE FROM XPTXX
EXPT6B: MOVE R,F ;RESTORE R, AND LEAVE OLD D IN NORMF
EXPT6C: PUSHJ FXP,SAV5 ;EXPECTS RUNNING SQUARER IN R, ACCUMULATION IN TT
PUSHJ P,BNCV ;NOTE THAT D CANT BE ZERO WHEN WE COME HERE
MOVE B,A ;ACCUMULATION AS BIGNUM IN B
MOVE TT,R
PUSHJ P,BNCVTM
MOVE A,TT ;RUNNING SQUARER IN A
EXPT1A: MOVEM A,-4(P)
MOVE D,NORMF
EXPT1: TRNN D,1 ;-4(P) AND A HAVE RUNNING SQUARER, B HAS ACCUMULATION
JRST EXPT2
MOVEM D,NORMF
PUSHJ P,BNMUL
MOVE D,NORMF
EXCH A,-4(P)
EXPT3: LSH D,-1 ;-4(P) NOW HAS ACCUMULATION, A HAS RUNNING SQUARER
JUMPE D,EXPT4
MOVE B,A
MOVEM D,NORMF
PUSHJ P,BNMUL
MOVE B,-4(P)
JRST EXPT1A
EXPT2: MOVEM B,-4(P)
JRST EXPT3
EXPT4: JSP R,RSTR5
PUSHJ P,BNCONS
JRST POPJ1
XPTBX: SOJG D,XPTBX1 ;BIGNUM↑FIXNUM
AOJG D,CPOPJ ; X↑1 => X
MOVEI A,IN0
JUMPL D,CPOPJ ; X↑-N => 0
AOJA A,CPOPJ ; X↑0 => 1 ;HACK HACK - IN0 => IN1
XPTBX1: MOVE A,TT ;EXPONENT > 1
SOS (P) ;COUNTERACT POPJ1 IN EXPT1
PUSHJ FXP,SAV5
MOVE B,BN.1 ;1, STORED AS A BIGNUM
AOJA D,EXPT1 ;RESTORE VALUE OF D
] ;END OF IFN BIGNUM
;XPTII XPTI$ XPTZL 1.0PJ XPTZL1 XPTZL2 XPTZX XPTZX1 XPTM1
XPTII: PUSH P,CFIX1 ;SUBR 2 NCALLABLE (REAL NAME: ↑)
JSP T,FXNV1
JSP T,FXNV2
JRST 2,@[.+1]
PUSHJ P,XPTXX
POPJ P,
LERR [SIXBIT \ANSWER TOO BIG - ↑↑!\]
XPTI$: PUSH P,CFLOAT1 ;SUBR 2, NCALLABLE (REAL NAME: ↑$)
JSP T,FLNV1
JSP T,FXNV2
JRST 2,@[XPTLX] ;OVERFLOW MUST BE CLEAR ON ENTRY TO XPTLX
XPTZL: JUMPN TT,XPTZL1 ;FLONUM BASE (CFLOAT1 ON PDL)
SKIPN D ; 0.0↑X => 0.0,
1.0PJ: MOVSI TT,(1.0) ; EXCEPT 0.0↑0.0 => 1.0
POPJ P,
XPTZL1: JUMPGE D,XPTZL2 ; -Y 1 Y
MOVSI T,(1.0) ; X = (---)
FDVR T,TT ; X
MOVE TT,T
MOVMS D
XPTZL2: CAMN TT,[-1.0]
JRST XPTM1 ;BASE IS -1.0
CAMN TT,[1.0]
POPJ P, ;BASE IS 1.0
MOVSI T,(1.0) ;T GETS 1.0 IN ANY CASE
JRST (R)
XPTZX: JUMPN TT,XPTZX1 ;FIXNUM BASE - PDL HAS CFIX1
JUMPN D,CPOPJ ; 0↑X => 0,
AOJA TT,CPOPJ ; EXCEPT 0↑0 => 1
XPTZX1: CAMN TT,XC-1 ;BASE = -1
JRST XPTM1
CAIN TT,1 ;FOR BASE = 1, ALSO EASY
POPJ P,
MOVEI T,1 ;T GETS 1 IN ANY CASE
JRST (R)
XPTM1: TRNN D,1 ;FOR BASE = -1 OR -1.0, SIMPLY
MOVMS TT ; ASCERTAIN PARITY OF EXPONENT
POPJ P,
;RANDOM RAND1 IRAND IRAND0 IRAND3 IRAND5 RNDM1 RNDM2 RNDM0 RNDM1A RNDM2A
SUBTTL RANDOM
RANDOM: SKIPA F,CFIX1
MOVEI F,CPOPJ
AOJG T,RNDM0
AOJLE T,RAND9
POP P,A
JUMPE A,IRAND ;ONE ARG OF NIL CAUSES INITIALIZATION
PUSH P,F
JSP F,RNDM0
MOVE D,TT ;ANY OTHER ARGUMENT SHOULD BE A
JSP T,FXNV1 ; FIXNUM N, AND WE GENERATE A
JUMPLE TT,RAND1 ; FIXNUM IN THE RANGE 0 TO N-1
TLZ D,400000
IDIV D,TT
SKIPA TT,R
RAND1: SETZ TT, ;RETURN 0 FOR NON-POSITIVE ARGUMENTS
POPJ P,
IRAND: MOVE TT,[171622221402] ;A GOOD STARTING NUMBER
IRAND0: MOVEI T,LRBLOCK-1 ;INITIALIZE THE RANDOMNESS
IRAND3: MOVE D,TT
MULI D,3125.
DIV D,[377777777741]
MOVEM R,TT
TLCE T,400000
JRST IRAND5
HRLM R,RBLOCK(T)
JRST IRAND3
IRAND5: HRRM R,RBLOCK(T)
SOJGE T,IRAND3
MOVEI D,ROFSET
MOVEM D,RNOWS
RNDM1: MOVEI T,LRBLOCK-1
MOVEM T,RBACK
JRST RNDM1A
RNDM2: MOVEI D,LRBLOCK-1
MOVEM D,RNOWS
JRST RNDM2A
RNDM0: SOSGE T,RBACK ;BASIC COMBINATION FOR RANDOMNESS
JRST RNDM1
RNDM1A: SOSGE D,RNOWS
JRST RNDM2
RNDM2A: MOVE TT,RBLOCK(T)
ADDB TT,RBLOCK(D)
JRST (F)
;HAULONG .HAU 4HAU 3HAU1 1HAU 2HAU 3HAU
SUBTTL HAULONG FUNCTION
HAULONG: PUSH P,CFIX1
.HAU:
BG$ JSP T,NVSKIP
BG$ JRST 1HAU
BG% JSP T,FLTSKP
JRST 4HAU
%WTA FXNMER
JRST .HAU
4HAU: MOVM D,TT
MOVEI TT,35.+1
3HAU1: JFFO D,.+2
TDZA TT,TT
SUBI TT,(R)
POPJ P,
IFN BIGNUM,[
1HAU: MOVEI F,(TT) ;RECEIVES BN HEADER IN TT
HRRZ R,(F) ;LEAVES HAULONG IN TT, PTR TO NEXT TO LAST
MOVEI TT,35.+1 ;IN F, CNT OF # OF ZEROS FOR LAST WD IN R
JUMPE R,3HAU
2HAU: ADDI TT,35.
HRRZ D,(R)
JUMPE D,3HAU
MOVEI F,(R)
MOVEI R,(D)
JRST 2HAU
3HAU: HLRZ T,(R)
MOVE D,(T)
JRST 3HAU1
] ;END OF IFN BIGNUM
;HAIPART 0HAI 0HAI1 0HAI2 0HAI3 3HAI 3HAI1 3HAI2 3HAI3
SUBTTL HAIPART FUNCTION
HAIPART:
IFN BIGNUM,[
JSP T,NVSKIP
JRST 1HAI
]
IFE BIGNUM,
JSP T,FLTSKP
JRST 0HAI
%WTA FXNMER
JRST HAIPART
0HAI: MOVM TT,TT
JFFO TT,.+2
JRST 0POPJ ;FOR ZERO ARG, JUST RETURN ARG!
HRREI F,-36.(D) ;-<# OF BITS IN ARG> NO IN AC F
JSP T,FXNV2
JUMPLE D,0HAI1
ADD D,F
JUMPG D,PDLNKJ ;MORE DIGITS REQUESTED THAN ARE AVAILABLE
LSH TT,(D) ;GETTING HAI PART INTO AC TT
JUMPGE TT,FIX1
IFN BIGNUM, JRST ABSOV
IFE BIGNUM, JRST OVFLER
0HAI1: JUMPE D,0POPJ ;RETURNS A FIXNUM ZERO
CAMGE D,F
JRST 0HAI3
MOVNS D
0HAI2: SETO F, ;REQUESTING LOW PART BY NEG COUNT
LSH F,(D) ;CREATE MASK TO LET PROPER BITS THRU
ANDCM TT,F
JRST FIX1
0HAI3: JUMPGE TT,PDLNKJ
IFN BIGNUM, JRST ABSOV
IFE BIGNUM, JRST OVFLER
IFN BIGNUM*USELESS,[
3HAI: MOVNS D ;ACTUALLY ASKING FOR LOW PART
CAILE D,35.
JRST 3HAI1
JUMPE D,0POPJ
HLRZ TT,(TT)
MOVE TT,(TT)
JRST 0HAI2
3HAI1: PUSH FXP,D
PUSHJ P,1HAU
POP FXP,D
CAIL D,(TT)
JRST PDLNKJ
IDIVI D,35.
PUSH P,C
MOVEI F,C ;F WILL BE POINTER TO LAST OF FORMNG LIST
MOVE C,(A) ;C HOLDS POINTER TO FNAL RESULT
MOVEI B,(C) ;B GOES CDR'ING DOW INPUT ARG
3HAI2: HLRZ TT,(B)
MOVE TT,(TT)
PUSHJ P,C1CONS
HRRM A,(F)
MOVEI F,(A)
HRRZ B,(B)
SOJG D,3HAI2 ;D HOLDS HOW MANY WORDS TO USE
JUMPE R,3HAI3 ;R HOLDS HOW MANY LEFT OVER BITS FROM D WORDS
HLRZ TT,(B)
MOVE TT,(TT)
MOVNI D,1
LSH D,(R)
ANDCM TT,D
JUMPE TT,3HAI3
PUSHJ P,C1CONS
HRRM A,(F)
3HAI3: MOVEI A,(C)
PUSH P,AR1
PUSHJ P,BNTRUN ;IN LOPART CASE, MAY NEED TO GET
POP P,AR1 ; RID OF LEADING ZEROS
POP P,C
HRRZ B,(A) ;MAYBE WHAT WE HAVE IS SHORT ENOUGH
JUMPN B,BGNMAK ; TO FIT IN A FIXNUM; IF SO, WE CAN
JRST CAR ; USE ONE WE JUST CONSED FOR BIGNUM!
] ;END OF IFN BIGNUM*USELESS
;LNGTER LENGTH LNGTH0 LNG1A LNGTH1 LNGTE1 LNGTH2 LNGTH5 LNGTH6 BIGP
SUBTTL LENGTH AND BIGP FUNCTIONS
LNGTER: WTA [NON-LIST - LENGTH!]
JRST LNGTH0
LENGTH: SKIPA T,CFIX1
MOVEI T,CPOPJ
LNGTH0: SKIPE V.RSET
JRST LNGTH5 ;FOR *RSET MODE, USE SLOW ERROR-CHECKING LOOP
LNG1A: MOVEI TT,777777 .SEE $LISTEN ;SAVES R
LNGTH1: JUMPE A,LNGTH2
HRRZ A,(A)
SOJG TT,LNGTH1
LNGTE1: MOVEI TT,(A) ;MAKNUM
JSP T,FXCONS
WTA [LIST IS CIRCULAR - LENGTH!]
JRST LNGTH0
LNGTH2: XORI TT,777777 ;ONE'S COMPLEMENT!
JRST (T)
LNGTH5: MOVEI TT,777777
LNGTH6: SKIPN D,A ;DONE IF NIL SEEN
JRST LNGTH2
LSH D,-SEGLOG
SKIPL ST(D) .SEE LS
JRST LNGTER
HRRZ A,(A)
SOJG TT,LNGTH6
JRST LNGTE1
IFE BIGNUM, BIGP==:FALSE
IFN BIGNUM,[
BIGP: PUSHJ P,TYPEP ;SUBR 1 - IS IT A BIGNUM?
CAIE A,QBIGNUM
SETZ A, ;RETURNS T OR NIL
JRST NOTNOT
] ;END OF IFN BIGNUM
;BOOLE BOOLL BOOLG BOOL1 ODDP1 ODDP ODDP2 ODDP21 ODDP4 ODDP3
SUBTTL BOOLE AND ODDP FUNCTIONS
BOOLE: SKIPA F,CFIX1
MOVEI F,CPOPJ
MOVE R,T
ADDI R,2(P)
HRLI T,-1(T)
MOVEM T,PLUS8
MOVE A,-1(R)
JSP T,FXNV1
DPB TT,[350400,,BOOLI]
PUSHJ P,BOOLG
MOVE D,TT
BOOLL: PUSHJ P,BOOLG
XCT BOOLI
JRST BOOLL
BOOLG: CAIL R,(P)
JRST BOOL1
MOVE A,(R)
JSP T,FXNV1
AOJA R,CPOPJ
BOOL1: ADD P,PLUS8
POP P,B
JRST (F)
ODDP1: %WTA FXNMER
ODDP: SKOTT A,FX
IFN BIGNUM, JRST ODDP4
IFE BIGNUM, JRST ODDP1
ODDP2:
MOVE TT,(A)
ODDP21: TRNN TT,1
JRST FALSE
JRST TRUE
IFN BIGNUM,[
ODDP4: TLNN TT,BN
JRST ODDP1
MOVE TT,(A)
ODDP3: HLRZ TT,(TT)
MOVE TT,(TT)
JRST ODDP21
] ;END OF IFN BIGNUM
;$FSC $ROT $LSH SHIFTY .GCD .GCD0 .GCD3 .GCD1 .GCD2 GCD0 GCD GCDXX
SUBTTL FSC, ROT, LSH, AND GCD FUNCTIONS
$FSC: JSP T,FLTSKP ;SUBR 2
JFCL
JSP T,FXNV2
CAIG D,-1
FSC TT,(D)
JRST FLOAT1
$ROT: SKIPA R,[ROT TT,(D)] ;SUBR 2
$LSH: HRLZI R,(LSH TT,(D)) ;SUBR 2
PUSH P,CFIX1
SHIFTY: JSP T,FLTSKP
JFCL
JSP T,FXNV2
XCT R
POPJ P,
IFN USELESS,[
IFE BIGNUM, GCD:
.GCD: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE
JSP T,FXNV1 ;GCD OF FIXNUM ARGS ONLY
JSP T,FXNV2
MOVM TT,TT ;GCD(-X,Y) = GCD(X,Y)
MOVM D,D ;GCD(X,-Y) = GCD(X,Y)
.GCD0: JUMPE TT,.GCD2 ;GCD(0,Y) = ABS(Y)
JUMPE D,CPOPJ ;GCD(X,0) = ABS(X)
CAMGE D,TT
EXCH D,TT
JRST .GCD1
.GCD3: MOVE D,TT
MOVE TT,R
.GCD1: IDIV D,TT ;GOOD OLD EUCLIDEAN ALGORITHM
JUMPN R,.GCD3
POPJ P,
.GCD2: MOVE TT,D
POPJ P,
IFN BIGNUM,[
GCD0: %WTA FXNMER ;NON-FIXNUM VALUE
GCD: SETZ R, ;SUBR 2 - GCD, EVEN OF BIGNUM ARGS
JSP T,NVSKIP
TRO R,1 ;TURN ON BIT IF BIGNUM
JRST .+2 ;FIXNUMS ARE OK TOO
JRST GCD0 ;DON'T LIKE FLONUMS
EXCH A,B
MOVE D,TT
JSP T,NVSKIP ;NOW CHECK OTHER ARG
TRO R,2
JRST .+2
JRST GCD0 ;I TOLD YOU, I DON'T LIKE FLONUMS!
JRST .+1(R) ;SO FIGURE OUT THIS MESS
JRST GCDXX ;FIXNUM AND FIXNUM
EXCH A,B ;FIXNUM AND BIGNUM
JRST GCDBX ;BIGNUM AND FIXNUM
JRST GCDBG ;BIGNUM AND BIGNUM
GCDXX: MOVM TT,TT ;GCD OF TWO FIXNUMS
JUMPL TT,GCDOV1 ;CHECK OUT -400000000000 CASES
MOVM D,D
JUMPL D,GCDOV
PUSH P,CFIX1 ;EVERYTHING OKAY - CAN USE .GCD0
JRST .GCD0
] ;END OF IFN BIGNUM
] ;END OF IFN USELESS
;$EQUAL $EQL1 $IEQ IEQUAL $LESS $GREAT $IGL1 $IGL IGRT IADD1 $ADD1 ISUB1 $SUB1
SUBTTL FUNCTIONS: = < > 1+ 1+$ 1- 1-$
$EQUAL: JSP T,FLTSKP ;NUMERIC EQUAL =
JRST IEQUAL
EXCH A,B
MOVE D,TT
$EQL1: JSP T,FLTSKP
JRST 2EQNF
$IEQ: CAME D,TT
JRST FALSE
JRST TRUE
IEQUAL: EXCH A,B
MOVE D,TT
JSP T,FLTSKP
JRST $IEQ
JRST 1EQNF
$LESS: EXCH A,B
$GREAT: JSP T,FLTSKP ;NUMERIC GREATERP AND LESSP <,>
JRST IGRT
MOVE D,TT
EXCH A,B
$IGL1: JSP T,FLTSKP
JRST 2GPNF
$IGL: CAMG D,TT
JRST FALSE
JRST TRUE
IGRT: MOVE D,TT
MOVE A,B
JSP T,FLTSKP
JRST $IGL
JRST 1GPNF
IADD1: JSP T,FLTSKP ;FIXNUM ADD1 1+
AOJA TT,FIX1
%WTA IARERR
JRST IADD1
%WTA $ARERR
$ADD1: JSP T,FLTSKP ;FLONUM ADD1 1+$
JRST $ADD1-1
FADRI TT,(1.0)
JRST FLOAT1
ISUB1: JSP T,FLTSKP ;FIXNUM SUB1 1-
SOJA TT,FIX1
%WTA IARERR
JRST ISUB1
%WTA $ARERR
$SUB1: JSP T,FLTSKP ;FLONUM SUB1 1-$
JRST $SUB1-1
FSBRI TT,(1.0)
JRST FLOAT1
;$ARITH IARITH I$B I$ART2 ARITH IARDS ARIT0
SUBTTL FUNCTIONS: + +$ - -$ * *$ // //$
$ARITH: SETOM PLUS0
SKIPA
IARITH: SETZM PLUS0 ;SET UP FOR FIXNUM ARITHMETIC
AOJGE T,ARIT0
I$B: JRST 2,@[.+1]
SKIPA B,T
I$ART2: XCT R
POP P,A ;MAIN LOOP FOR FIXNUM AND FLONUM ARITHMETIC
ARITH: JSP T,FLTSKP ;MAKE SURE NO MIXED MODES, RETURN MACHINE NUMBER IN TT
TDZA T,T
MOVNI T,1
CAME T,PLUS0
JRST ARTHER
AOJLE B,I$ART2
CAIN B,69.+1 ;SIGNAL FOR CASE WITH ONE ARG
EXCH TT,D
XCT F
IARDS: SKIPE PLUS0 ;DISPATCH TO CONS UP FINAL ANSWER
JRST FLOAT1
JRST FIX1
ARIT0: MOVE TT,D
JUMPN T,IARDS
MOVEI T,69.
JRST I$B
;IDIFFERENCE IPLUS IQUOTIENT ITIMES $DIFFERENCE $PLUS $QUOTIENT $TIMES IARZAR
IDIFFERENCE:
SKIPA F,[SUB TT,D] ;-
IPLUS: MOVE F,[ADD TT,D] ;+
MOVE R,[ADD D,TT]
MOVEI D,0
JRST IARITH
IQUOTIENT:
SKIPA F,[IDIV TT,D] ;/
ITIMES: MOVE F,[IMUL TT,D] ;*
MOVE R,[IMUL D,TT]
MOVEI D,1
JRST IARITH
$DIFFERENCE:
SKIPA F,[FSBR TT,D] ;-$
$PLUS: MOVE F,[FADR TT,D] ;+$
MOVE R,[FADR D,TT]
MOVEI D,0
JRST $ARITH
$QUOTIENT:
SKIPA F,[FDVR TT,D] ;/$
$TIMES: MOVE F,[FMPR TT,D] ;*$
MOVE R,[FMPR D,TT]
MOVSI D,(1.0)
JRST $ARITH
IARZAR: MOVE TT,D
JRST FIX1
;$SIN SIN. SIN.0 SIN.1 SIN.2 SIN.XT PI%2 SIN.CF COS COS.
;;; ********** NUMBER SUBRS FOR LISP **********
SUBTTL SIN AND COS FUNCTIONS
;;; SIN IS A TOPS-10/TENEX JSYS, SO MUST CALL THIS $SIN. FOO! - GLS
$SIN: PUSH P,CFLOAT1
SIN.: JSP T,FLTSKP
JSP T,IFLOAT
MOVM T,TT ;SIN(-X)=-SIN(X)
CAMLE T,C1.0E5 ;ARG SHOULD BE <= 1.0E5 (ELSE RESULT
JRST SIN.ER ; WOULD BE GROSSLY INACCURATE)
CAMG T,[.001] ;THE RELATIVE ERROR OF APPROXIMATION [BY THIS RATIONAL
; ; FUNCTION] IS BOUNDED BY ABOUT 2.0E-7, BUT OCCASIONALLY
; ; COMES CLOSE TO THIS. SINCE THE ERROR OF TRUNCATION
; ; INHERENT IN TAKING X-(1/6)*X**3 FOR THE TAYLOR SERIES
; ; OF SIN(X) IS MUCH LESS THAN 2.0E-7, IT WILL BE SUFFICIENT
; ; TO TAKE X FOR SIN(X) WHENEVER THE RELATIVE ERROR TERM
; ; [(1/6)*X**3] IS LESS THAN 2.0E-7. SOLVING, WE FIND
JRST SIN.XT ; X=.001 WILL DO.
EXCH T,TT
SIN.0: FDVR TT,PI%2 ;DIVIDE ARG BY PI/2 (ARG IS NOW IN QUADRANTS)
MULI TT,400 ;TT GETS CHARACTERISTIC, R GETS MANTISSA
SETZB R,F
ASHC D,-243(TT) ;D GETS INTEGER PART, R GETS FRACTION (OF ARG)
ASHC R,-8. ;R GETS HIGH 27. BITS OF FRACTION, F GETS REST
TLO R,200000 ;FLOAT R
LSH F,-8.
TLO F,145000 ;FLOAT F (NOTE: 145=200-33; R,F NOW FORM 2-WORD FLOATING NUMBER)
FADR R,F ;ADD F TO R (THIS WHOLE MESS PRESERVES PRECISION AND NORMALIZES)
TRCN D,3 ;R IS NOW A QUADRANT 1 ANGLE - WHAT WAS ORIGINAL QUADRANT?
JRST SIN.1 ;QUADRANT 1 - ALL IS WELL
TRCE D,3
MOVN T,T ;QUADRANT 2 OR 3 - MUST REVERSE SIGN: SIN(X)=-SIN(X-PI)
TRNE D,1
FSBR R,FPWUN ;QUADRANT 2 OR 4 - SUBTRACT 1 TO PUT IN RANGE -1.0 TO 0
SIN.1: SKIPGE T ;TEST SINE SIGN FLAG
MOVN R,R ;IF NEGATIVE, RESULT MUST BE NEGATIVE
MOVE D,R
FMPR D,D ;D <- R*R IS ALWAYS NON-NEGATIVE
MOVE TT,SIN.CF+4 ;MOBY APPROXIMATION
MOVEI T,3
SIN.2: FMPR TT,D
FADR TT,SIN.CF(T)
SOJGE T,SIN.2
FMPR TT,R
SIN.XT: CAMLE TT,[1.0] ;THIS IS A CROCK TO MAKE SURE ABS(RESULT) NOT >1
MOVSI TT,(1.0)
CAMGE TT,[-1.0]
MOVSI TT,(-1.0)
POPJ P, ;RETURN - RESULT IS IN TT
PI%2: 1.570796326 ;A PIECE OF PI (ABOUT 50%)
SIN.CF: 1.5707963185 ;COEFFICIENTS FOR SIN APPROXIMATION
-0.6459637111
0.07968967928
-0.00467376557
0.00015148419
COS: PUSH P,CFLOAT1
COS.: JSP T,FLTSKP
JSP T,IFLOAT
SKIPLE T,TT
MOVN T,TT
FADR T,PI%2 ;PI/2-X IN T, SINCE COS(X) = SIN(PI/2-X)
MOVM TT,T ;|PI/2-X| IN TT
CAMLE TT,C1.0E5
JRST COS.ER
JRST SIN.0
;SQRT SQRT. SQRT.. SQRT.1
SUBTTL SQRT FUNCTION
COMMENT | OLD SQRT ALGORITHM
SQRT: PUSH P,CFLOAT1
SQRT.: JSP T,FLNV1
JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR
SQRT..: MOVE D,TT ;D GETS ARG
LDB T,[341000,,TT] ;FOR FIRST APPROXIMATION, TRY
ADDI T,100 ; HALVING CHARACTERISTIC OF ARGUMENT,
DPB T,[331100,,TT] ; AND USE SAME MANTISSA
MOVEI T,5 ;NOW DO MOBY ITERATION
SQRT.1: MOVE R,TT ; R <- TT
MOVE TT,D
FDVR TT,R ; R + D/R
FADR TT,R ; TT <- ---------
FSC TT,-1 ; 2
SOJN T,SQRT.1
POPJ P,
| ;END OF OLD SQRT ALGORITHM
;SQRT SQRT. SQRT..
COMMENT | ANOTHER OLD SQRT ALGORITHM
;;; THIS SQRT ALGORITHM IS BASED ON ONE BY KAHAN, ORIGINALLY
;;; DESIGNED FOR THE IBM 7094. THAT VENERABLE MACHINE LOOKED
;;; LIKE THE PDP-10 (27.-BIT MANTISSA AND 8-BIT EXPONENT).
;;; (THANKS TO RJF FOR HELP IN CODING THIS.)
;;;
;;; THE IDEA IS TO DECOMPOSE THE ARGUMENT X INTO:
;;; F * 2.0↑(2*I - J)
;;; WHERE THE FRACTION F IS BETWEEN 0.5 (INCLUSIVE) AND 1.0
;;; (EXCLUSIVE), AND I AND J ARE INTEGERS, J BEING 0 OR 1.
;;; ONE THEN COMPUTES THE INITIAL APPROXIMATION AS:
;;; A0 = (C + F/2.0 - J/4.0) * 2.0↑I
;;; WHERE C IS THE MAGIC CONSTANT 0.4826004, CHOSEN FOR THE
;;; BEST POSSIBLE FIT TO A CURVE. ONE THEN PERFORMS AN
;;; ITERATION CALCULATING:
;;; A<K+1> = (A<K> + X/A<K>)/2.0
;;; ALL ARITHMETIC IS DONE WITHOUT ROUNDING EXCEPT LAST ADD.
;;; THREE ITERATIONS SHOULD SUFFICE; A3 IS THE RESULT.
;;; THE INITIAL APPROXIMATION CAN BE CALCULATED QUICKLY BY
;;; MEANS OF THE FOLLOWING TRICK. LET THE EXPONENT BE
;;; E = 2*I - J = 2*N + M
;;; SUCH THAT M IS 0 OR 1; THEN J=M AND I=N+M. MOREOVER,
;;; NOTE THAT THE PDP-10 EXPONENT X=E+200 (OCTAL), BECAUSE
;;; OF EXCESS-200 NOTATION. HENCE X=2*(N+100)+M.
;;; WE FIRST PICK OFF THE M BIT AS A SEPARATE WORD AND
;;; SHIFT IT RIGHT. THANKS TO THE PARTICULAR REPRESENTATION
;;; OF EXPONENT AND FRACTION, THIS PRODUCES A WORD WITH
;;; A FRACTION OF M/2. NOW WE WILL ADD TOGETHER THIS WORD,
;;; THE ORIGINAL ARGUMENT, AND A MAGIC CONSTANT, AND SHIFT
;;; THE SUM RIGHT BY 1. SHIFTING AFTERWARDS GIVES GREATER
;;; ACCURACY AND TAKES FEWER INSTRUCTIONS, BUT FOR PURPOSES
;;; OF EXPOSITION LET US ASSUME THE THREE SUMMANDS TO HAVE
;;; BEEN PRE-SHIFTED.
;;; SHIFTING THE ORIGINAL ARGUMENT RIGHT PRODUCES A WORD WITH
;;; FRACTION F/2+M/2 AND MACHINE EXPONENT N+100. SHIFTING
;;; THE M/2 PRODUCES M/4. THE MAGIC CONSTANT IS CHOSEN SUCH
;;; THAT, WHEN SHIFTED, ITS FRACTION IS C (0.4826004) AND
;;; ITS MACHINE EXPONENT IS 100. ADDING THESE TOGETHER
;;; PRODUCES FRACTION F/2 + 3*M/4 + C AND MACHINE EXPONENT
;;; N+200. HOWEVER, SINCE F IS NORMALIZED, THE ADDITION
;;; OF 3*M/4 IS GUARANTEED TO OVERFLOW INTO THE EXPONENT FIELD;
;;; THIS RESULTS IN SUBTRACTING M/4 FROM THE FRACTION, AND
;;; ADDING M INTO THE MACHINE EXPONENT. THE RESULT IS THUS:
;;; (C + F/2 - M/4) * 2.0↑(N+M)
;;; WHICH IS THE DESIRED VALUE.
SQRT: PUSH P,CFLOAT1
SQRT.: JSP T,FLNV1
JUMPG TT,SQRT..
JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR
POPJ P, ;ZERO ARGUMENT => ZERO
;;; POSITIVE ARGUMENT IS IN TT NOW
SQRT..: MOVE R,TT ;SAVE ARGUMENT IN R FOR LATER
MOVS D,TT
ANDI D,1000
LSH D,22-1 ;D HAS M/2 AS A SINGLE BIT
ADD TT,D ;ADD INTO ORIGINAL ARGUMENT
ADD TT,[200756135462] ;EXPONENT 200, FRACTION 2*0.4826004
LSH TT,-1 ;NOW WE HAVE INITIAL APPROXIMATION
IRPC ROUND,,[ R]AC,,[DDR]
IFSN AC,R, MOVE D,R ; TT + R/TT
FDV AC,TT ;COMPUTE TT <- ---------
FAD!ROUND TT,AC ; 2
FSC TT,-1 ;LAST TIME ONLY, ADD ROUNDED
TERMIN
POPJ P,
| ;END OF ANOTHER OLD SQRT ALGORITHM
;SQRT SQRT. SQRT.. SQRT.2 SQRT.3
;;; I HAVE NO IDEA HOW THIS WORKS! - GLS
;;; THANKS TO RJF AND KAHAN.
;;; KAHAN CLAIMS THE ERROR LIES BETWEEN -.5 AND +.516 LSB'S
SQRT: PUSH P,CFLOAT1
SQRT.: JSP T,FLNV1
JUMPG TT,SQRT..
JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR
POPJ P, ;ZERO ARGUMENT => ZERO
;;; POSITIVE ARGUMENT IS IN TT NOW
SQRT..: MOVE R,TT ;SAVE ARG FOR LATER
ASH TT,-1
ADD TT,[265116421] ;THAT'S 265116421 (KAHAN BLACK MAGIC)
TLON TT,400
JRST SQRT.2
FMPRI TT,301461 ;(301461)=(FSC 1.19140625 100)
JRST SQRT.3
SQRT.2: FMPRI TT,300653 ;(300653)=(FSC 0.833984375 100)
;NOW TWO NEWTON ITERATIONS, MODIFIED
SQRT.3: MOVE D,R
FDV D,TT ;UNROUNDED DIVIDE
FAD TT,D ;UNROUNDED ADD
; FSC TT,-1
SUB TT,[1000002645] ;KAHAN SEZ: INSTEAD OF DIVISION BY 2, SUBTRACT 1000002645
FDV R,TT ;UNROUNDED DIVIDE
FADR TT,R ;ROUNDED ADD!
FSC TT,-1
POPJ P,
;;; A FEW HINTS, PAINFULLY WORKED OUT BY GLS AND RZ:
;;; THE ASH BY -1 DIVIDES THE EXPONENT BY 2, AND MUNCHES
;;; THE MANTISSA IN A BIZARRE WAY.
;;; THE ADDITION OF 265116421 IS GUARANTEED TO CARRY
;;; INTO THE 3.9 BIT, ASSUMING A NORMALIZED INPUT. THIS
;;; WILL COMPLEMENT THE ORIGINAL LOW EXPONENT BIT.
;;; THIS IS THEN TESTED BY THE TLON, WHICH ALSO FORCES
;;; THE 3.9 BIT ON, MAKING THE NEW NUMBER NORMALIZED.
;;; THE SUBTRACTION OF 1000002645 INDEED DIVIDES BY 2,
;;; BY SUBTRACTING 1 FROM THE EXPONENT; AND THE REST DOES
;;; A WEIRD LITTLE PERTURBATION WHICH, HOWEVER, CANNOT
;;; BORROW FROM THE EXPONENT.
;LOG LOG. LOG.. LOG.1 LOG.2 ROOT2 LOG.CF NUMFLT NUMFL3
SUBTTL LOG FUNCTION
LOG: PUSH P,CFLOAT1
LOG.: PUSHJ P,NUMFLT
LOG..: JUMPLE TT,LOG.ER ;NON-POSITIVE ARG IS AN ERROR
MULI TT,400
HRREI TT,-201(TT) ;SAVE CHARACTERISTIC IN TT
LSH D,-8. ;REDUCE ARG TO VALUE X BETWEEN 1.0 AND 2.0
TLO D,201000
MOVEI R,0
CAMN D,FPWUN ;LOG(1.0)=0.0 (ALSO FOR WHOLE POWERS OF 2 THIS SAVES TIME)
JRST LOG.2
MOVE T,D ; X - SQRT(2)
FSBR T,ROOT2 ; T <- -------------
FADR D,ROOT2 ; X + SQRT(2)
FDVRB T,D
FMPR D,D ; D <- T*T
MOVEI F,3 ;MOBY APPROXIMATION TO LOG BASE 2
LOG.1: FMPR R,D
FADR R,LOG.CF(F)
SOJGE F,LOG.1
FMPR R,T
FADR R,[0.5]
LOG.2: JSP T,IFLOAT ;FLOAT CHARACTERISTIC
FADR TT,R ;ADD TO LOG OF MANTISSA
FMPR TT,[0.6931471806] ;MULTIPLY BY LN 2 TO GET LOG BASE E
POPJ P,
ROOT2: 1.4142135625 ;SQRT(2)
LOG.CF: 2.885390073 ;COEFFICIENTS FOR LOG APPROXIMATION
0.9618007623
0.5765843421
0.4342597513
NUMFLT:
IFE BIGNUM, JSP T,FLTSKP
IFN BIGNUM, JSP T,NVSKIP
IFN BIGNUM, JRST NUMFL3
JSP T,IFLOAT
POPJ P,
IFN BIGNUM,[
NUMFL3: PUSH P,A
PUSHJ P,FLBIG
JRST POPAJ
] ;END OF IFN BIGNUM
;ATAN ATAN. ATAN.1 ATAN.2 ATAN.3 ATAN.4 PI% ATAN.C
SUBTTL ATAN FUNCTION
ATAN: PUSH P,CFLOAT1
ATAN.: EXCH A,B
PUSHJ P,NUMFLT
PUSH FXP,TT
MOVEI A,(B)
PUSHJ P,NUMFLT
POP FXP,D
MOVM R,TT ;GET ABSOLUTE VALUE OF Y
MOVM F,D ;GET ABSOLUTE VALUE OF X
MOVEM R,ATAN.Y ;SAVE ABS(Y)
MOVEM F,ATAN.X ;SAVE ABS(X)
HLR D,TT ;D HAS <LEFT HALF OF X>,,<LEFT HALF OF Y>
MOVEM D,ATAN.S ;SAVE THAT MESS (HAS SIGNS OF X AND Y)
MOVE T,R
JFCL 8,.+1
FSBR T,F ; ABS(Y)-ABS(X)
FADR R,F ; T <- -----------------
FDVRB T,R ; ABS(Y)+ABS(X)
FMPR R,R ; R <- T*T
MOVE D,ATAN.C+7 ;MOBY APPROXIMATION
MOVEI F,6
ATAN.1: FMPR D,R
FADR D,ATAN.C(F)
SOJGE F,ATAN.1
FMPR D,T
MOVM TT,D
CAMGE TT,[.7855]
CAMGE TT,[.7853]
JRST ATAN.3
JUMPGE D,ATAN.2 ;PATCH UP FOR WHEN RATIONAL APPROXIMATION NOT VERY GOOD
MOVE D,ATAN.Y ;WE CAN USE Y/X FOR ATAN (Y/X)
FDVR D,ATAN.X
JRST ATAN.4
ATAN.2: MOVN D,ATAN.X
FDVR D,ATAN.Y
FADR D,PI%2
JRST ATAN.4
ATAN.3: FADR D,[0.7853981634] ;PI/4
ATAN.4: MOVN TT,D ;NOW WE HAVE A QUADRANT 1 RESULT (CALL IT Q)
FADR TT,PI% ;PATCH-UP STUFF TO GET RIGHT QUADRANT
SKIPL F,ATAN.S ; X>0 I X<0
EXCH D,TT ;-------------------------I-------------------------
FSC D,1 ; D <- PI-Q I D <- Q
TRNE F,400000 ; TT <- Q I TT <- PI-Q
FADR TT,D ; Y>0 I Y<0 I Y>0 I Y<0
JFCL 8,ATAN.7 ;------------I------------I------------I------------
POPJ P, ; TT<-Q I TT<-2*PI-Q I TT<-PI-Q I TT<-PI+Q
PI%: 3.1415926536 ;A WELL-KNOWN NUMBER
ATAN.C: 0.9999993329 ;COEFFICIENTS FOR ATAN APPROXIMATION
-0.3332985605
0.1994653599
-0.139085335
0.0964200441
-0.0559098861
0.0218612288
-0.004054058
;EXP EXP. EXP.. EXP.A EXP.1 EXP.2 EXP.RX EXP.3 EXP.CF FPWUN INTLG C1.0E5 YPOCB BCOPY BCOP1 BNARSV BNARRS
SUBTTL EXP FUNCTION
EXP: PUSH P,CFLOAT1
EXP.: JSP T,FLTSKP
JSP T,IFLOAT
EXP..: SETZ R,
MOVEM TT,EXP.S ;SAVE SIGN OF ARG ON PDL
MOVM TT,TT ;GET ABSOLUTE VALUE OF ARG
CAMLE TT,[88.0] ;WAS REQUESTED POWER > 88.0?
JRST EXP.A ;YES, CAN'T REPRESENT SOMETHING THIS BIG
FMPR TT,[0.4342944819] ;LOG BASE 10. OF E
;FROM NOW ON WE DO 10.↑X, NOT E↑X
MOVE F,FPWUN ;F HOLDS 10.↑<INTEGER PART OF ARG>
CAMG TT,FPWUN ;IF ARG <=1.0 GO DO RATIONAL APPROXIMATION
JRST EXP.RX
MULI TT,400
ASHC D,-243(TT) ;D GETS INTEGER PART OF ARG
; CAIG D,43 ;THIS IS OLD CHECK, JONL SAYS OK TO ALLOW
JRST EXP.1 ; LARGER RANGE
EXP.A: SKIPGE TT,EXP.S ;TOO LARGE - RESULT CAN'T BE REPRESENTED
TDZA TT,TT
JRST EXP.ER
POPJ P, ;NEGATIVE ARG PRODUCES ZERO (UNDERFLOW)
EXP.1: CAIG D,7 ;SKIP IF INTEGER PART OF ARG > 7
JRST EXP.2
LDB T,[030300,,D] ;GET TOP 3 BITS OF 6 BIT INTEGER PART
ANDI D,7 ;AND THEM OUT OF D
MOVE F,INTLG(T) ;F GETS (10.↑T)↑8. = 10.↑(T*8.)
FMPR F,F
FMPR F,F
FMPR F,F
EXP.2: FMPR F,INTLG(D) ;MULTIPLY F BY APPROPRIATE 10.↑D (0<=D<=7)
LDB TT,[103300,,R] ;NOW GET FRACTION PART OF ARG
TLO TT,177000 ;THIS STRANGENESS FLOATS
FADR TT,TT ; AND NORMALIZES THE FRACTION
EXP.RX: MOVEI T,6 ;MOBY APPROXIMATION
SKIPA R,EXP.CF+6
EXP.3: FADR R,EXP.CF(T)
FMPR R,TT
SOJGE T,EXP.3
FADR R,FPWUN
FMPR R,R
FMPR F,R ;MULTIPLY FRACTION APPROXIMATION BY 10.↑<INTEGER PART>
MOVE TT,FPWUN
SKIPL EXP.S
SKIPA TT,F ;IF ARG>0, RETURN RESULT
FDVR TT,F ;IF ARG<0, RETURN 1.0/RESULT
POPJ P,
EXP.CF: 1.151292776 ;COEFFICIENTS FOR EXP APPROXIMATION
0.6627308843
0.2543935748
0.07295173666
0.01742111988
2.55491796↑-3
9.3264267↑-4
FPWUN: ;FLOATING POINT 1.0
INTLG: 1.0 ;TABLE OF 10.↑X FOR INTEGRAL 0<=X<=7
REPEAT 7, 1.0↑<.RPCNT+1>
C1.0E5=FPWUN+5
PGTOP ARI,[ARITHMETIC SUBROUTINES]
;;@ END OF ARITH 78
;;; REMEMBER THE SUNDER HACK, AND DONT HACK THIS $INSRT
IFN BIGNUM,[
;;@ BIGNUM 13 BIGNUM ARITHMETIC PACKAGE
;;; ***** MACLISP ****** BIGNUM ARITHMETIC PACKAGE ***************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1976 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT BIG
SUBTTL BIGNUM PACKAGE - RANDOM ROUTINES
;THE BIGNUM ARITHMETIC PAGE - SPECIAL STUFF FOR BIGNUM OPERATIONS ONLY
YPOCB: PUSH P,[NREVERSE]
BCOPY: HRRZ C,A ;COPIES A BIGNUM IN ACCUMULATOR A [INTERNAL FORMAT]
PUSH P,A
MOVEI AR1,(P) ;CLOBBERS C AR1 TT D
BCOP1: JUMPE C,POPAJ
HLRZ TT,(C)
MOVE TT,(TT)
PUSHJ P,C1CONS
HRRM A,(AR1)
HRRZ AR1,(AR1) ;UPDATE POINTER TO END OF LIST
HRRZ C,(C) ;GET NEXT OF LIST TO BE COPIED
JRST BCOP1
BNARSV: PUSH P,C ;SAVE ACCUMULATORS
PUSH P,AR1
PUSH P,AR2A
MOVEM F,FACD
MOVEM R,FACF
JRST (T)
BNARRS: POP P,AR2A ;RESTORE ACCUMULATORS
POP P,AR1
POP P,C
MOVE F,FACD
MOVE R,FACF
JRST (T)
;PLOV PLOV2 PL1BN TIMOV TIM1BN T2 T12 PL2BN
PLOV: PUSH P,AR1 ;OVERFLO WHILE ADDING OR SUBBING TWO FIXNUMS
SKIPN TT,D
JRST PLOV2
TLNN TT,400000
MOVNS TT
TLZ TT,400000
PUSH FXP,TT
PUSHJ P,ABSOV
MOVE A,(A)
HLR B,(A)
POP FXP,(B)
SKIPL D
TLC A,-1
SKIPA D,A
PLOV2: MOVE D,BNM236
POP P,AR1
JRST T13
PL1BN: EXCH D,TT ;FIXNUM SUM MEETS BIGNUM ARG
PUSHJ P,BNCVTM
EXCH D,TT
JRST T11
TIMOV: MOVEM T,AGDBT ;OVERFLO WHILE MULING TWO FIXNUMS
PUSHJ P,BNCV
MOVE D,A
MOVE TT,AGDBT
PUSHJ P,BNCVTM
JRST BNTIM
TIM1BN: JUMPE D,T14EX ;FIXNUM PRODUCT MEETS BIGNUM NEXT ARG
EXCH D,TT
PUSHJ P,BNCVTM
EXCH D,TT
JRST T11
T2: MOVE D,TT
T12: MOVE A,(F) ;BIGNUM ARITHMETIC LOOP
JSP T,NVSKIP
XCT 4(R) ;OPERATE ON TWO BIGNUMS
JRST 2(R) ;DISPATCH TO OPERATE ON BIGNUM SUM WITH FIXED
EXCH D,TT ;CONVERT BIGNUM SUM TO FLOATING
PUSHJ P,FLBIG
EXCH D,TT
JRST T7 ;AND ENTER FLOATING POINT LOOP
PL2BN: PUSHJ P,BNCVTM ;BIGNUM SUM MEETS FIXNUM NEXT ARG
JRST T11
;TIM2BN T11 T13 T13X BNDF BNPL BNPL1 T19A T19B T19C BNXTIM BNTIM
TIM2BN: JUMPE TT,T14EX1 ;BIGNUM PRODUCT MEETS FIXNUM NEXT ARG
PUSHJ P,BNCVTM
EXCH D,TT
T11: XCT 4(R) ;TRANSFERS TO BNTIM
T13: AOBJN F,T12
T13X: MOVE A,D
SUB P,PLUS8
JRST BNCONS
BNDF: JSP A,BNPL1 ;DIFFERENCE OF TWO BIGNUMS
BNPL: JSP A,BNPL1 ;PLUS OF TWO BIGNUMS
BNPL1: EXCH A,D
MOVE B,TT
JSP T,BNARSV
PUSHJ P,BNADD(D)-BNPL1
T19A: PUSHJ P,BNTRSZ ;SKIPS 2 IF ALL RIGHT
MOVE D,[1←43]
JRST T19B
MOVE D,A
HRRZ B,(A) ;WHAT IF OPERATE RESULTS IN SCRUNCHING
JUMPN B,T19C ;ACCUMULATED VALUE INTO ONE WORD?
HLRZ D,(A)
MOVE D,(D)
JUMPGE A,.+2
MOVNS D
T19B: JSP T,BNARRS
JRST 2,@[T14E]
T19C: JSP T,BNARRS
JRST T13
BNXTIM: JUMPE TT,0POPJ ;FIXNUM IN TT TIMES ABS(BIGNUM IN A)
HRRZ D,(A)
SETOM REMFL
PUSHJ P,BNCVTM ;CONVERT FIXNUM TO BIGNUM FOR BNMUL
BNTIM: JSP T,BNARSV ;PRODUCT OF TWO BIGNUMS
MOVE A,D
MOVE B,TT
PUSHJ P,BNMUL
JSP T,BNARRS
MOVE D,A
SKIPN REMFL
JRST T13
SETZM REMFL
JRST BNCONS ;FOR BNXTIM, CONS UP A REAL BIGNUM
;DIVSEZ REM2BN DV2BN DV1BN BNDV
DIVSEZ: SKIPA D,BNM235 ;DIVISION BY 1←43 [-2E35.]
REM2BN: JUMPE TT,BPDLNKJ
DV2BN: JSP T,BNARSV ;BIGNUM DIVIDEND GETS FIXNUM DIVISOR
MOVE A,D
JUMPN TT,DV2BN1
SKIPN RWG
JRST OVFLER
MOVEI TT,1 ;ON ATTEMPT TO DIVIDE BY ZERO [WHEN RWG NOT ZERO]
JUMPGE A,.+2
MOVNS TT
MOVEM TT,BNV1
MOVE B,BNV2
PUSHJ P,BNADD
JRST T19A
DV1BN: CAME D,[400000,,] ;FIXNUM DIVIDEND, BIGNUM DIVISOR
TDZA TT,TT ;ORDINARILY ZERO
SKIPA D,BNM235 ;BUT -4←41/4←41 => 1, NOT 0
JRST T14EX1
BNDV: MOVE B,TT ;BIGNUM QUOTIENT, BIGNUM DIVEND
MOVE A,D
JSP T,BNARSV
PUSHJ P,BNQUO
SKIPE REMFL
CAMN TT,XC-1
JRST T19A
SETZM REMFL
JSP T,BNARRS
MOVE D,A ;DIVIDE OUT NORMALIZATION
JRST DV2BN
;DV2BN1 DV2BN2 BNFXLP DV2BN3 D1FIN
DV2BN1: MOVEM A,NORMF ;SO DIVIDE A BIGNUM BY A REGULAR FIXNUM
PUSHJ P,REVERSE
MOVE AR1,NORMF ;AR1 HAS SIGN OF ORIGINAL ARG IN LH
HRR AR2A,A ;AR2A HAS SIGN OF PRODUCT ON COPY
HLL AR2A,AR1
JUMPGE TT,DV2BN2
MOVNS TT
JUMPL TT,DV2BN3 ;FOO! LOUSY SETZ CASE - PRODUCT WILL BE NEGATIVE
TLC AR2A,-1
DV2BN2: HRRZ C,(A)
MOVE D,TT
HLRZ F,(A)
MOVE F,(F)
MOVEI R,0
DIV R,D
MOVE TT,R
PUSHJ P,C1CONS
BNFXLP: MOVE B,A
JUMPE C,D1FIN
MOVE R,F
HLRZ F,(C)
MOVE F,(F)
DIV R,D
MOVE TT,R
PUSHJ P,C1CONS
HRRM B,(A)
HRRZ C,(C)
JRST BNFXLP
DV2BN3: MOVE TT,BNM235
JSP T,BNARRS
JRST BNDV
D1FIN: HLL A,AR2A
PUSHJ P,BNTRUN
EXCH A,AR2A
MOVEI B,NIL
PUSHJ P,RECLAIM ;RECLAIM ONLY FREE STORAGE
EXCH A,AR2A
SKIPN REMFL
JRST T19A
MOVE D,F
JUMPGE AR1,.+2
MOVNS D
JSP T,BNARRS
MOVEI B,TRUTH
PUSHJ P,RECLAIM ;RECLAIM QUOTIENT SPACE, SINCE ONLY REMAINDER NEEDED
JRST T14EX
;BNTRUN BNTR4 BNTRSZ BNTRS1 BNPJ2 BNCV BNCVTM T17 T16 T23
SUBTTL GENERAL UTILITY ROUTINES FOR BIGNUM ARITHMETIC
BNTRUN: HRR AR1,A ;TRUNCATE OFF LEADING ZEROS FROM BIGNUM
HRRZ B,(AR1) ;PRESERVE LH OF AR1
JUMPE B,CPOPJ
BNTR4: MOVS C,(B)
SKIPE (C)
HRR AR1,B
HLRZ B,C
JUMPN B,BNTR4
HRRZ C,(AR1)
HLRM C,(AR1)
JUMPE C,CPOPJ ;EXIT IF THERE WERE NO LEADING ZEROS
EXCH A,C
PUSHJ P,RECLAIM ;OTHERWISE, RECLAIM SPACE OCCUPIED
EXCH A,C ; BY LIST HOLDING THEM (B IS ZERO)
POPJ P,
BNTRSZ: JUMPGE A,BNPJ2 ;SKIPS 2 IF NOT -1←43 IN BIGNUM FORMAT. ELSE NO SKIP
BNTRS1: HRRZ AR1,(A) ;MUNGS ONLY AR1
JUMPE AR1,BNPJ2
MOVS AR1,(AR1)
TLNE AR1,-1
JRST BNPJ2
HLL AR1,(AR1) ;ALL THIS KLUDGERY SO THAT RANDOM
TLNE AR1,-1 ; NUMERIC QUANTITIES WILL NOT GET
JRST BNPJ2 ; IN THE RIGHT HALF OF AR1
HRLZ AR1,(AR1)
TLC AR1,1
JUMPN AR1,BNPJ2
HLRZ AR1,(A)
SKIPN (AR1)
POPJ P,
BNPJ2: POP P,AR1
JRST 2(AR1)
BNCV: PUSH FXP,D
PUSHJ FXP,SAV5M1
PUSHJ P,BNCVTM
MOVE A,TT
PUSHJ P,BCOPY
JRST UUOSE1
BNCVTM: JUMPL TT,T16 ;CONVERT NUMBER IN TT TO INTERNAL BIGNUM
T17: MOVEM TT,BNV1
MOVE TT,BNV2
POPJ P,
T16: MOVNS TT
JUMPL TT,T23 ;400000,,
PUSHJ P,T17
TLCA TT,-1
T23: MOVE TT,BNM235 ;CONVERTED TO BIGNUM -2E35.
POPJ P,
;BNSUB BNADD BN4 BN15 BN20 BN7 BN9 BNADD2 BN14 BN8 BN5 BN13 BN6
SUBTTL BIGNUM ADDITION SUBROUTINE
BNSUB: TLC B,-1 ;CHANGE SIGN OF 2ND ARG
BNADD: MOVE C,A ;FIRST ARGUMENT TO C
HLLZ A,C ;SET UP NULL BIGNUM WITH SIGN OF FIRST ARG
PUSH P,A
HLLZ F,B ;DITTO SECOND ARG
MOVEI R,BNADD2 ;SET UP FOR REAL ADD
CAME A,F ;CHECK FOR SAME SIGNS
MOVEI R,BNSUB2 ;CHANGE TO SUBTRACT
MOVE F,P ;F POINTS TO BOTTOM WORD OF ANSWER
MOVEI TT,0 ;ARITHMETIC DONE IN TT
BN4: MOVE AR2A,C
MOVE C,(C) ;CDR C
MOVE B,(B) ;CDR B
BN15: MOVEI D,0 ;CLEAR CARRY
HLRZ AR1,C
ADD TT,(AR1)
HLRZ AR1,B
XCT -1(R) ;ADD/SUB TT,(AR1)
TLZE TT,400000 ;CARRY OR BORROW
MOVE D,-2(R) ;PLUS OR MINUS 1
JSP T,FWCONS
MOVE AR1,A
PUSHJ P,ACONS
HRRM A,(F) ;NCONC ONTO ANSWER
MOVE F,A ;UPDATE POINTER TO LAST WORD
BN20: TRNN B,-1 ;END OF SECOND ARG?
JRST @-3(R)
BN7: TRNN C,-1 ;END OF FIRST ARG?
JRST (R)
BN9: MOVE TT,D ;MOVE CARRY TO TT
JRST BN4
BN5
1 ;CARRY
ADD TT,(AR1)
BNADD2: JUMPN D,BN8 ;FIRST ARG DONE; IF CARRY, SIMULATE A ZERO
BN14: HRRM B,(F) ;USE REST OF SECOND ARG
JRST POPAJ
BN8: MOVEI C,[R70,,]
JRST BN9
BN5: JUMPN D,BN6 ;2ND ARG EXHAUSTED; IF CARRY, SIMULATE A ZERO
BN13: HRRM C,(F)
JRST POPAJ
BN6: MOVEI B,[R70,,]
JRST BN7
;BNSUB2 BN10 BN11 BN11A BN12 BNM1 BNM2
BN12
-1 ;BORROW
SUB TT,(AR1)
BNSUB2:
;COME HERE ONLY IF ABS(1)<ABS(2)
;FIRST ARG DONE, AND (2ND IS NOT DONE, OR THERE IS A BORROW)
;IT IS NECESSARY TO TAKE THE TWOS COMPLEMENT OF THE PARTIAL ANSWER
MOVE A,(P)
TLC A,-1
MOVEM A,(P)
MOVSI TT,400000 ;TT IS INITIALIZED TO 400000000000
;AND UNCHANGED WHILE THE PARTIAL ANSWER IS ZEROS
;AFTER A NONZERO WORD, TT IS RESET TO 377777777777 AFTER EACH SUBTRACT
SKIPA C,(A) ;SCAN DOWN NUMBER; LEFT HALF OF C NOW POINTS AT LOW ORDER WORD
BN10: MOVE C,(C)
HLRZ AR1,C
SUBB TT,(AR1)
SKIPL TT ;IFF TT IS STILL SETZ, (AR1) WAS ZERO AND MUST BE FIXED
SKIPA TT,[377777777777]
SETZM (AR1)
TRNE C,-1
JRST BN10
JUMPL D,BN11 ;IF BORROW: THE PARTIAL ANSWER WAS NONZERO TO GENERATE THE BORROW
;A RECOMPLEMENT BORROW OCCURED. TT IS 377777777777.
;SHOULD USE REST OF 2ND ARGUMENT
JUMPL TT,BN14 ;TT<0: THE PARTIAL ANSWER WAS ZERO; 1ST ARG IS PROPER INITIAL SEGMENT OF 2ND ARG
;USE REST OF 2ND ARG, GUARANTEED TO BE NONZERO
MOVNI TT,1 ;RECOMPLEMENT BORROW BUT NO ORIGINAL BORROW; USE REST OF 2ND ARG WITH BORROW
MOVE C,(B) ;SWAP ARGS
MOVSI B,[0]
JRST BN15 ;CONTINUE AS A SUBTRACT IN WHICH "2ND" ARG IS EXHAUSTED, AND A BORROW PROPAGATED
;CURIOUS THINGS HAPPEN IF THE REST OF "1ST" ARG IS ZERO(AN IMPROPER FORMAT)
BN11: TLNE B,-1 ;TRY TO AVOID USING THE TRUNCATE ROUTINE
JRST BN14 ;REST OF 2ND ARG IS NOT NULL, SO USE IT
BN11A: POP P,A
SKIPE (AR1) ;AR1 POINTS AT HIGH WORD OF DIFFERENCE
POPJ P,
JRST BNTRUN
BN12: JUMPN D,BN6 ;2ND ARG EXHAUSTED; IF BORROW, INVENT A ZERO
TRNE C,-1 ;IF 1ST ARG IS NOT EXHAUSTED, USE REST OF IT
JRST BN13
JRST BN11A ;BOTH ARGS EXHAUSTED
BNM1: JUMPE D,POPAJ ;SWAP OUT ONLY A NONZERO CARRY
PUSH P,CPOPAJ ;FOR MULTIPLICATION ROUTINE
BNM2: EXCH D,TT
JSP T,FWCONS
PUSHJ P,ACONS
EXCH D,TT
HRRM A,(R) ;NCONC CARRY WORD TO ANSWER BIGNUM
POPJ P,
;BNMUL BNM5 BNM4 BNM3
SUBTTL BIGNUM MULTIPLICATION SUBROUTINE
;MULTIPLY IS DONE IN TWO PARTS: (1) MULTIPLY FIRST ARG BY FIRST WORD OF SECOND ARG
;(2) MULTIPLY [AND ADD IN TO TOTAL] FIRST ARG BY EACH REMAINING WORD OF THE SECOND ARG
;SLIGHTLY FASTER IF SECOND ARG IS SHORTER
BNMUL: MOVE C,A
HLLZ A,C ;CREATE NULL BIGNUM WITH SIGN OF FIRST ARG
XOR A,B ;SKIP IF 2ND ARG POSITIVE. CHANGE SIGN OF ANSWER
PUSH P,A
MOVE R,P ;R POINTS AT LAST WORD OF ANSWER BIGNUM DURING PART ONE OF MULTIPLY
MOVE B,(B) ;GET FIRST WORD OF SECOND ARG
HLRZ F,B
MOVE F,(F)
MOVEI D,0 ;ZERO CARRY WORD
SKIPA AR2A,(C) ;PREPARE TO GOBBLE FIRST ARG
BNM5: MOVE AR2A,(AR2A)
HLRZ T,AR2A ;GOBBLE A WORD OF FIRST ARG
MOVE T,(T)
MUL T,F ;AFTER MULTIPLY, T<377777777777
ADD TT,D ;CARRY<400000000000; SUM<777777777777
MOVE D,T
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS D ;NEW CARRY<400000000000
PUSHJ P,C1CONS
HRRM A,(R)
MOVE R,A ;UPDATE POINTER TO LAST WORD
TRNE AR2A,-1 ;END OF FIRST ARG?
JRST BNM5
MOVE A,(P)
HRRM A,BNMSV
BNM4: TRNN B,-1 ;END OF SECOND ARGUMENT?
JRST BNM1 ;YES; SWAP OUT CARRY IF NOT ZERO
PUSHJ P,BNM2
MOVE B,(B) ;GET NEXT WORD OF SECOND ARG
HLRZ F,B
MOVE F,(F)
MOVE R,@BNMSV
HRRM R,BNMSV
MOVE AR2A,(C) ;RESET FIRST ARGUMENT
MOVEI D,0 ;CLEAR OUT CARRY
BNM3: HLRZ T,AR2A ;GET A WORD OF FIRST ARG
MOVE T,(T)
MUL T,F ;AFTER MULTIPLY, T<377777777777
ADD TT,D ;CRY<400000000001, SUM<1000000000000
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS T ;NEW T<400000000000
HLRZ D,(R) ;GET WORD OF ACCUMULATOR
ADD TT,(D) ;SUM<777777777777
TLZE TT,400000 ;CLEAR SIGN BIT AND PROPAGATE
AOS T ;NEW T<400000000001
MOVEM TT,(D) ;STORE WORD OF ACCUMULATOR
MOVE D,T
TRNN AR2A,-1 ;SKIP IF NOT END OF FIRST ARG
JRST BNM4
MOVE AR2A,(AR2A) ;ADVANCE TO NEXT WORD OF FIRST ARG
MOVE R,(R) ;ADVANCE TO NEXT WORD OF ACCUMULATOR
JRST BNM3
;BNQUO BNQUO1 BQ1 BQ2
SUBTTL BIGNUM DIVISION SUBROUTINE
BNQUO: SETZM NORMF ;INITIALIZE NORMALIZATION FACTOR
SETZM VETBL0 ;INITIALIZE "FIRST TIME THRU" FLAG
PUSH P,B ;SETS UP TO TEST FIRST DIVISOR WORD
PUSH P,A
BNQUO1: MOVEI D,1
MOVE C,B
MOVE C,(C)
MOVE AR1,(C)
AOS D
TRNE AR1,-1
JRST .-4
HLRZS AR1
MOVE F,(AR1)
CAMGE F,[200000,,0] ;NORMALIZATION TEST
JRST BQNORM
SKIPN NORMF
JRST BQCOPY
MOVSS C ;GET TOP TWO DIVISOR WORDS
MOVE C,(C)
MOVEM F,DVS1
MOVEM C,DVS2
MOVEM D,DVSL
MOVEI C,(A) ;SET UP QUOTIENT
JUMPGE B,.+2
TLC A,-1
HLLZS A
TLZ B,-1 ;PROB. UNNECESSARY, BUT WHY TAKE CHANCES?
PUSH P,A
BQ1: MOVEI R,3 ;THIS GETS DVD WORDS FOR THE QUOTIENT ESTIMATE
MOVE AR2A,C
BQ2: MOVE AR2A,(AR2A)
TRNN AR2A,-1
JRST BQSRRM ;PARTIAL REMAINDER IS ONLY ONE WORD LONG
MOVE T,(AR2A)
TRNN T,-1
JRST BQSHRM ;PARTIAL REM OR DVD IS 2 WORDS LONG
MOVE TT,(T)
TRNE TT,-1
AOJA R,BQ2
JRST BQCC
;BQCC BQGEST BQZQ BQCOPY BQNORM
BQCC: MOVSS AR2A
MOVE AR2A,(AR2A)
MOVEM AR2A,DD3
MOVSS T
MOVE T,(T)
MOVEM T,DD2
MOVSS TT
MOVE TT,(TT)
MOVEM TT,DD1
SKIPN VETBL0
JRST BQVET
MOVEM R,DDL
BQGEST: SUB R,DVSL ;CHECKS FOR PARTIAL REMAINDER<DIVISOR
JUMPL R,BQZQ
JUMPN R,BQGESS
EXCH R,DD1 ;SINCE R WAS 0, NOW DD1 IS 0
MOVEM R,DD2
JRST BQGESS
BQZQ: SETZM QHAT
JRST BQ8
BQCOPY: SETOM NORMF ;COPIES DIVIDEND TO GET WORK SPACE
PUSHJ P,BCOPY ;CLOBBERS T TT D B C AR1
MOVEM A,(P)
MOVE B,-1(P)
JRST BNQUO1
BQNORM: ADDI F,1 ;THIS SECTION MULTIPLIES DVD AND DIV BY NORMF
MOVEI T,1
SETZ TT,
DIV T,F
MOVEM T,NORMF
MOVE A,B
MOVEM T,BNV1
MOVE B,BNV2
PUSHJ P,BNMUL
EXCH A,(P)
MOVE B,BNV2
PUSHJ P,BNMUL
MOVE B,A
EXCH B,(P)
MOVEM B,-1(P)
JRST BNQUO1
;BQ6 BQSRRM BQSHRM BQVET BQSHRT REMFIN BQ10 BQDD BQ11
BQ6:
BQSRRM: SETZM QHAT ;COME HERE IF PARTIAL REM IS ONE WORD
JRST BQ8 ;MEANS QUOTIENT AT THIS STEP IS ZERO
BQSHRM: MOVEI R,2 ;COME HERE IF PARTIAL REMAINDER IS 2 WORDS LONG
MOVSS AR2A
MOVSS T
MOVE T,(T)
MOVE AR2A,(AR2A)
MOVEM T,DD2
MOVEM AR2A,DD3
SETZM DD1
SKIPE VETBL0
JRST BQGESS
JRST BQ10
BQVET: MOVEM TT,DD2
MOVEM T,DD3
SETZM DD1
JRST BQ10
BQSHRT: MOVE A,-1(P)
JUMPE R,BQSH0
SKIPE REMFL
JRST REMFIN
HLLZS R
HRRM R,-1(P)
JRST BQ6
REMFIN: HLL A,-1(P)
TRNN A,-1
MOVE A,-1(P) ;IN CASE DIVIDEND IS REMAINDER
PUSHJ P,BNTRUN
MOVE TT,NORMF
SUB P,R70+3
POPJ P,
BQ10: SUB R,DVSL ;SETS UP INITIAL ZERO FOR FIRST GUESS
SKIPG R
JRST BQSHRT
SOSN R
JRST BQ1DF
MOVEM R,DDL
MOVE F,C
BQDD: MOVE F,(F)
MOVE TT,(F)
SOJLE R,BQ11
JRST BQDD
BQ11: MOVEI A,(TT)
MOVEI R,0
HRRM R,(F)
MOVE C,A
JRST BQGESS
;BQ5 BQ7 BQ8 BQ9 BQ9A BQ9B
BQ5: MOVE AR2A,[377777777777]
BQ7: MOVE A,C ;MULTIPLY,SUBTRACT,AND ADD BACK LOOP
MOVEM AR2A,QHAT
SETZB AR2A,AR1
MOVE B,-2(P)
MOVE D,QHAT
PUSHJ P,BQSUB
HLLZS (AR2A)
PUSHJ P,BNTRUN
BQ8: SETOM VETBL0 ;QUOTIENT STORING LOOP
SKIPE REMFL
JRST BQ9
MOVE AR1,A
EXCH TT,AGDBT
MOVE TT,QHAT
PUSHJ P,C1CONS
MOVE F,(P)
HRRM F,(A)
HRRM A,(P)
MOVE A,AR1
EXCH TT,AGDBT
BQ9: MOVE B,-1(P) ;BRING DOWN A NEW DVD WORD
TRNN B,-1
JRST BQFIN
MOVE C,(B)
TRNN C,-1
JRST BQEFIN
BQ9A: MOVE AR1,(C)
TRNN AR1,-1
JRST BQ9B
MOVE B,(B)
MOVE C,(B)
JRST BQ9A
BQ9B: MOVEI AR1,0
HRRM AR1,(B)
HRRM A,(C)
HRR A,C
PUSHJ P,BNTRUN
MOVE C,A
JRST BQ1
;BQEFIN BQSH0 BQ1DF BQGESS BQCHEK BQC2 BQC1 BQFIN
BQEFIN: MOVEI C,0
HRRM C,-1(P)
MOVE C,B
JRST BQ9B
BQSH0: HLLZS R
HRRM R,-1(P)
JRST BQGESS
BQ1DF: HRRZ A,(C)
MOVEI R,0
HRRM R,(C)
MOVE C,A
BQGESS: JRST 2,@[.+1]
MOVE D,DVS1 ;CLEARS NO DIVIDE FLAG
MOVE T,DD1
MOVE TT,DD2
DIV T,D
JSP R,.+1
TLNE R,40
JRST BQ5
JUMPE T,BQ6
MOVE AR2A,T
BQCHEK: MUL T,D
MOVE R,DD1
MOVE F,DD2
SUB F,TT
TLZ F,400000
MOVE R,F
MOVE F,DD3
MOVE T,DVS2
MUL T,AR2A
CAMG T,R
JRST BQC1
BQC2: SOJA AR2A,BQ7
BQC1: CAMN T,R
CAMG TT,F
JRST BQ7
JRST BQC2
BQFIN: SKIPE REMFL
JRST REMFIN
SETZB A,B
EXCH A,-1(P)
PUSHJ P,RECLAIM
EXCH A,-2(P) ;NOTE: RECLAIM RETURNED NIL
AOSE NORMF
PUSHJ P,RECLAIM
POP P,A
SUB P,R70+2
JRST BNTRUN
;BQSUB BQSUB0 BQSUB7 BQSUB1 BQSUB6
BQSUB: MOVEI R,0 ;THIS MULTIPLIES DIVISOR BY PARTIAL QUOTIENT ESTIMATE
BQSUB0: MOVE AR2A,A ;AND SUBTRACTS FROM THE PARTIAL REMAINDER
MOVE A,(A) ;AND ADDS BACK IF THE ESTIMATE WAS TOO LARGE
MOVE B,(B) ;THE NEW PARTIAL REMAINDER IS STORED IN
HLRZ T,B ;THE SAME WORDS AS THE OLD PART. REM.
MOVE T,(T)
MUL T,D
MOVS AR1,A
ADD TT,R
TLZE TT,400000
AOS T
EXCH TT,(AR1)
SUBB TT,(AR1)
TLZE TT,400000
AOS T
MOVEM TT,(AR1)
TRNN B,-1
JRST BQSUB1
BQSUB7: TRNN A,-1
JRST BQSUB3
MOVE R,T
JRST BQSUB0
BQSUB1: JUMPN T,BQSUB6
MOVE A,C
POPJ P,
BQSUB6: MOVEI B,[R70,,NIL]
JRST BQSUB7
;BQSUB3 BQSUB4
;;; KNUTH SAYS THE FOLLOWING PIECE OF CODE (ADDING BACK) IS
;;; NEEDED IN ONLY ABOUT 3 OR 4 CASES IN 34 BILLION. HERE
;;; ARE TWO NUMBERS ACCIDENTALLY DISCOVERED BY GOSPER WHICH
;;; WILL CAUSE THIS ADDING BACK TO HAPPEN:
;;; THE DIVIDEND IS:
;;; 2791789817939938387128631852330682768655711099796886
;;; 76652915704481188064205113686384821261582354
;;; 6679451522036433421137784129286923496509.
;;; THE DIVISOR IS:
;;; 888654299197548479101428655285643704385285845048283
;;; 973585973531.
;;; TO SEE WHY HE DISCOVERED IT, TRY LOOKING AT THE QUOTIENT!
;;;
;;; HERE ARE TWO MORE NUMBERS WHICH EXCUTE THIS CODE; FURTHERMORE,
;;; THEY CAUSE THE OVER-SUBTRACTED DIVIDEND TO BE SHORTER THAN
;;; THE DIVISOR; THIS IS THE REASON FOR THE COPYING BELOW.
;;; (GOSPER ALSO DISCOVERED THESE NUMBERS!)
;;; THE DIVIDEND IS:
;;; 814814390533794434507378275363751264420699600792121
;;; 5135985742227369051304412442580926595072.
;;; THE DIVISOR IS:
;;; 10889035741470030830827987437816582766593.
BQSUB3: HLLZS (AR2A) ;CHOP OFF END OF ANSWER STORAGE
MOVE A,C
PUSHJ P,BNTRUN ;TRUNCATE ANSWER, WHICH IS A NEGATIVE NUMBER IN POSITIVE FORM
PUSH P,A
HRRZ A,-4(P) ;GET (ABSOLUTE VALUE OF) DIVISOR
PUSHJ P,BCOPY ;MUST COPY IT, OR ELSE CARRY
POP P,B ; TRUNCATION MIGHT CLOBBER IT!
PUSHJ P,BNADD ;SET UP ANSWER FOR ADD BACK
SKIPA B,A
BQSUB4: MOVE B,(B) ;CHOP OFF CARRY
MOVE C,(B)
HRRZ AR1,(C)
JUMPN AR1,BQSUB4
MOVE AR2A,B ;CARRY WILL BE CHOPPED OFF WHEN THIS POPJ'S
SOS QHAT ;CORRECT QUOTIENT GUESS
POPJ P,
;FLBIGF FLBIG FLBIGX FLBIGZ FLTB1 FLBIGQ FLBIGO
SUBTTL BIGNUM TO FLONUM CONVERSION
FLBIGF: JUMPN R,FLBIG
PUSH P,CFLOAT1
FLBIG: PUSHJ P,SAVX5 ;RECEIVES BIGNUM HEADER IN TT,
HLRZ A,TT ;LEAVES SIGN BIT IN AC A
HRRZ T,(TT) ;LEAVES RESULT AS NUMERIC IN TT
JUMPE T,FLTB1 ;SAVES ALL OTHER ACS
PUSHJ P,FLBIGZ
FADR TT,D ;ROUND UP
SKIPE RWG
JFCL 8.,FLBIGX
JFCL 8.,FLBIGO
FLBIGX: JUMPE A,.+2
MOVNS TT
MOVEM TT,-3(FXP)
JRST RSTX5
FLBIGZ: PUSHJ P,1HAU ;MUST BE > 27. BITS, OR ELSE WOULDN'T BE HERE
MOVEI T,(TT)
MOVEI D,27.
PUSHJ P,1HAI1 ;1HAI1 LEAVES TRAILING BITS IN TT+1
ASH TT+1,-8.
TLO TT,200000 ;INSTALL EXPONENTS
TLO TT+1,145000
JFCL 8.,.+1
TRNE T,-1#377 ;INSURE OVERFLOW IF EXPONENT IS TOO LARGE
TRO T,377
FSC TT,(T)
FSC TT+1,(T)
POPJ P,
FLTB1: HLRZ TT,(TT)
MOVE TT,(TT) ;ONE-WORD BIGNUM?
JSP T,IFLOAT
MOVE D,TT
JRST FLBIGX
FLBIGQ: HRROS (P) ;HACK SO THAT (*QUO <FLONUM> <HUGE-BIGNUM>)
JRST FLBIG ; WILL CAUSE UNDERFLOW, NOT OVERFLOW
FLBIGO: PUSHJ P,RSTX5
POP P,T
TLNN T,1 ;IF BIT 3.1 IS SET, SO IS 4.7 (SEE T7O0)
JRST OVFLER
AOJA T,T7O0
;FIXBIG FXBFV FXBFZ FBFIN FXBFQ MNSBG 4CHKRT
SUBTTL FLONUM TO BIGNUM CONVERSION
FIXBIG: JUMPN R,[LERR [SIXBIT \FIX HAS BIGNUM FOR ASSIGNMENT TO FIXNUM VARIABLE?!\]]
MOVE TT,T
MULI TT,400
JSP T,BNARSV
MOVE AR1,A
MOVE F,D
SUBI TT,200
IDIVI TT,43
SETZ R,
ASHC R,(D)
MOVE D,TT
JUMPE R,FXBFQ
MOVE TT,R
JSP T,FWCONS
PUSHJ P,NCONS
MOVE TT,F
MOVE C,A
FXBFV: JSP T,FWCONS
PUSHJ P,NCONS
HRRM C,(A)
MOVEI C,(A)
FXBFZ: SOJLE D,FBFIN
MOVEI TT,0
PUSHJ P,C1CONS
HRRM C,(A)
MOVEI C,(A)
JRST FXBFZ
FBFIN: SKIPG (AR1)
TLC A,-1
JSP T,BNARRS
JRST BNCONS
FXBFQ: MOVEI C,0
MOVE TT,F
JRST FXBFV
MNSBG: TLC TT,-1 ;MINUS, FOR BIGNUM
MOVE A,TT
4CHKRT: PUSHJ P,BNTRSZ ;FOR 100000000000, CONVERT
MOVE TT,[1←43] ; TO FIXNUM SETZ, ELSE
JRST FIX1
JRST BNCONS ; TO A REGULAR BIGNUM
;ABSBG0 ABSBG REMBIG GRBB GRBBL GRBR
SUBTTL ABS AND REMAINDER FOR BIGNUMS
ABSBG0: MOVE TT,(A)
ABSBG: JUMPGE TT,CPOPJ ;ABS FOR BIGNUM
HRRZ A,TT
JRST BGNMAK
REMBIG: EXCH A,B
MOVE D,TT ;REMAINDER FOR BIGNUM
SETZM PLUS8 ;SO THAT ARITHMETIC LOOP WILL RESTORE TO HERE
SETOM REMFL
JSP T,NVSKIP
JRST BNDV ;REMFL WILL STOP ARITHMETIC LOOP
JRST REM2BN
JSP T,REMAIR ;FOO! FLONUM ARG NOT COMPREHENSIBLE!
GRBB: SETZM NORMF ;GREATERP FOR BIGNUM WITH BIGNUM
MOVE A,D
MOVE B,TT
MOVE AR1,D
MOVE AR2A,TT
ASH TT,-43
ASH D,-43
CAME D,TT
JRST GRB13
SETO C,
GRBBL: TRNN AR1,-1
JRST GRB1
TRNN AR2A,-1
JRST GRB2
MOVS AR1,(AR1)
MOVS AR2A,(AR2A)
MOVE D,(AR1)
MOVE TT,(AR2A)
JUMPGE A,.+3
MOVNS D
MOVNS TT
XCT GRESS0
JRST GRBF
SETZ C,
GRBR: MOVSS AR1
MOVSS AR2A
JRST GRBBL
;GRFXB GRBFX GRBF GRB1 GRB12 GRB13 GRB14 GRB2 GRBBEL GRBBE2
SUBTTL GREATERP AND LESSP FOR BIGNUMS
GRFXB: SETZM NORMF ;GREATERP FOR FIXNUM WITH BIGNUM
PUSH FXP,D
MOVE B,TT
MOVEI AR2A,QBIGNUM
MOVEI AR1,QFIXNUM
TLNE D,400000
SKIPA D,XC-1
MOVEI D,1
JRST GRB14
GRBFX: SETZM NORMF ;GREATERP FOR BIGNUM WITH FIXNUM
PUSH FXP,TT
MOVE A,D
MOVEI AR1,QBIGNUM
MOVEI AR2A,QFIXNUM
TLNE TT,400000
SKIPA TT,XC-1
MOVEI TT,1
JRST GRB14
GRBF: CAMN D,TT
JRST GRBR
SETO C,
JRST GRBR
GRB1: TRNN AR2A,-1
JRST GRBBEL
MOVEI D,2
MOVEI TT,4
GRB12: TLNE A,1
EXCH D,TT
GRB13: MOVEI AR1,QBIGNUM
MOVEI AR2A,QBIGNUM
GRB14: XCT GRESS0
SKIPA C,[-1]
MOVEI C,0
JRST GRBBE2
GRB2: SETOM NORMF
MOVEI D,4
MOVEI TT,2
JRST GRB12
GRBBEL: MOVEI AR1,QBIGNUM
MOVEI AR2A,QBIGNUM
GRBBE2: MOVE D,A
MOVE TT,B
CAIN AR2A,QFIXNUM
POP FXP,TT
CAIN AR1,QFIXNUM
POP FXP,D
SKIPE NORMF
MOVNS C
SKIPN C
XCT CSUCE
XCT CFAIL
;1HAI 1HAI1 2HAI 2HAI2 2HAI0 2HAI3 2HAI4
SUBTTL HAIPART FOR BIGNUMS
IFN USELESS,[
1HAI: JSP T,FXNV2
JUMPLE D,3HAI
PUSH FXP,D
PUSHJ P,1HAU
POP FXP,D
CAILE D,35.
JRST 2HAI
PUSH P,CFIX1
] ;END OF IFN USELESS
;IN USELESS VERSION, 1HAI CALLED ONLY BY FLBIG
1HAI1: ADDI R,-35.-1(D) ;FINAL ANSWER FITS IN ONE WORD
HLRZ D,(F) ;SPREAD OUT HIGH WORD AND
MOVE D,(D) ;NEXT-TO-HIGH WORD INTO TT,D
HRRZ TT,(F)
HLRZ TT,(TT)
MOVE TT,(TT)
ASHC TT,(R)
POPJ P,
IFN USELESS,[
2HAI: SUBI TT,(D)
JUMPLE TT,CPOPJ
PUSHJ FXP,SAV3 ;COPY BIGNUM, BUT TOSS OUT LOW ORDER BITS
IDIVI TT,35. ;HOW MANY BITS TO THROW AWAY
MOVEI F,(A)
HRRZ F,(F)
SOJGE TT,.-1
MOVN C,D
SUBI D,35.
HLRZ TT,(F)
MOVE TT,(TT)
HRRZ F,(F) ;F IS CDR'ING DOWN INPUT
JUMPE F,2HAI0
HLRZ T,(F)
MOVE T,(T) ;C HOLDS AMNT TO SHIFT RIGHT BY
ASHC T,(C)
PUSHJ P,C1CONS
MOVEI B,(A)
2HAI2: MOVEI R,(A) ;R HAS PTR TO LAST OF FORMING LIST
HRRZ F,(F)
JUMPE F,2HAI3
ASHC T,(D) ;MOVE T INTO TT
HLRZ T,(F)
MOVE T,(T)
ASHC T,(C)
PUSHJ P,C1CONS
HRRM A,(R)
JRST 2HAI2
2HAI0: ASH TT,(C) ;DEFINITELY A BUG TO COME HERE,SINCE WE
JSP R,RSTR3
JRST FIX1 ;THINK WE ARE RETURNING A BIGNUM
2HAI3: JUMPE T,2HAI4
MOVE TT,T
PUSHJ P,C1CONS
HRRM A,(R)
2HAI4: MOVEI A,(B)
PUSHJ P,BGNMAK
POP P,C
JRST POP2J
] ;END OF IFN USELESS
;;; THE CODE FOR 3HAI IS PUTCODED.
;GCDBG GCDBG0 GCDBG1 GCDBG2 GCDBGU GCDBHU GCDBG4
IFN USELESS,[
SUBTTL GCD FOR BIGNUMS
GCDBG: MOVEI F,1 ;INITIALIZE SMALLNUM MATRIX
MOVEM F,GCD.A
MOVEM F,GCD.D
SETZM GCD.B
SETZM GCD.C
HLRZ R,(TT) ;GET LOW ORDER WDS OF ARGS
MOVE R,(R)
HLRZ F,(D)
MOVE T,R ;LOW WD OF U
IOR R,(F)
PUSH FXP,R
JUMPE R,GCDBG4 ;BOTH LOW WDS 0
MOVN R,R
ANDM R,(FXP) ;GRTST COMMON PWR OF 2 OR 0 IF > 2↑35.
PUSH FXP,(F) ;LOW WD OF V.
JUMPN T,GCDBG0 ;IF T=0 AND (F) EVEN, XTRA PWR OF 2 WILL
EXCH A,B ; COME BACK FROM RECURSION, SO SWAP TO
EXCH TT,D ; UNZERO T, THUS GUARANTEEING RECURSION WITH
EXCH T,(FXP) ; AT LEAST 1 ODD ARG.
GCDBG0: MOVEI R,(TT) ;GET HI WDS IF SAME LENGTH.
MOVEI F,(D)
HRRZ D,(D)
HRRZ TT,(TT)
JUMPE D,GCDBG2
JUMPN TT,GCDBG0
EXCH A,B ;B IS LONGER THAN A
GCDBG1: SUB FXP,R70+2
PUSH P,B ;A IS LONGER THAN B
PUSHJ P,REMAINDER ;SO GCD(A,B) = GCD(REMAINDER(A,B),B)
POP P,B
JRST GCD
GCDBG2: JUMPN TT,GCDBG1 ;U,V UNEQUALLY LONG
HLRZ R,(R) ;U,V EQUALLY LONG,
HLRZ F,(F) ; GET ACTUAL HI WDS.
MOVE TT,(R)
MOVE D,(F)
POP FXP,R ;TT,D HAVE HI WDS (OR 0 AND NON0 IF UNEQUAL LENGTH)
MOVEI F,35. ;T,R HAVE LO WDS
MOVEM F,GCD.UH ;SHFT CTR
GCDBGU: TRNE T,1
JRST GCDBGV ;U IS ODD
GCDBHU: LSH T,-1
LSH D,1 ;TT RIGHT 1 REL TO D
JUMPGE D,.+3
LSH D,-1
LSH TT,-1
MOVE F,GCD.C ;HALVING A, B EQUIV TO DOUBLING C,D
ADDM F,GCD.C
MOVE F,GCD.D
ADDM F,GCD.D
SOSE GCD.UH
JRST GCDBGU
GCDBG4: PUSH P,A
PUSH P,B
MOVE TT,GCD.A
PUSHJ P,BNXTIM
PUSH P,A ;T <- A*U
MOVE A,-1(P)
MOVE TT,GCD.B
PUSHJ P,BNXTIM
POP P,B
PUSHJ P,.PLUS ;T <- T+B*V
PUSHJ P,BNLWFL
EXCH A,-1(P)
MOVE TT,GCD.C
PUSHJ P,BNXTIM
EXCH A,(P) ;W <- C*U
MOVE TT,GCD.D
PUSHJ P,BNXTIM
POP P,B
PUSHJ P,.PLUS ;W <- W+D*V
PUSHJ P,BNLWFL
POP P,B ;U <- T
POP FXP,TT
CAIN TT,1
JRST GCD
PUSH FXP,TT
PUSHJ P,GCD
MOVEI B,(FXP)
SKIPN (B)
MOVEI B,BN235 ;CAN ONLY HAPPEN WHEN BOTH LO WDS 0
PUSHJ P,.TIMES
SUB FXP,R70+1
POPJ P,
;GCDBGV GCDBHV BNLWFL BNLWFX BNLWXX GCDBGO GCDBGT GCDBX GCDOV GCDOV1
GCDBGV: TRNE R,1
JRST GCDBGO ;BOTH U,V ODD
GCDBHV: LSH R,-1
LSH TT,1
JUMPGE TT,.+3
LSH TT,-1
LSH D,-1
MOVE F,GCD.A
ADDM F,GCD.A
MOVE F,GCD.B
ADDM F,GCD.B
SOSE GCD.UH
JRST GCDBGV
JRST GCDBG4
BNLWFL: HRRZ B,(A) ;FLUSH LOW 35. ZEROS OF A
JUMPE B,BNLWXX
HRRZ B,(B)
HRRZ C,(B)
JUMPE C,BNLWFX ;IF BIGNUM BECOMES FIXNUM
HRRM B,(A)
POPJ P,
BNLWFX: HLRZ A,(B)
POPJ P,
BNLWXX: SKIPE (A)
MOVEI A,IN0-1
POPJ P,
GCDBGO: CAML TT,D
JRST GCDBGT
SUB D,TT
SUB R,T
MOVN F,GCD.A
ADDM F,GCD.C
MOVN F,GCD.B
ADDM F,GCD.D
JRST GCDBHV
GCDBGT: SUB TT,D
SUB T,R
MOVN F,GCD.C
ADDM F,GCD.A
MOVN F,GCD.D
ADDM F,GCD.B
JRST GCDBHU
GCDBX: SKIPN D,(B) ;FIXNUM IS ZERO - RETURN BIGNUM
JRST ABSBG0 ;MAYBE NEED TO TAKE ABS VALUE
CAMN D,[400000,,] ;CHECK FOR NASTY -400000000000 CASE
JRST GCDOV
PUSH P,B ;ELSE TAKE A REMAINDER
PUSHJ P,REMAINDER
POP P,B
JRST .GCD ;GUARANTEED TO HAVE TWO FIXNUMS NOW
GCDOV: MOVEI B,(A) ;HANDLE NASTY -400000000000 CASES
GCDOV1: PUSHJ P,ABSOV
JRST GCD
] ;END OF IFN USELESS
PGTOP BIG,[BIGNUM-ONLY ARITHMETICS]
;;@ END OF BIGNUM 13
]
;POP3UB POP2UB EVALHOOK EVNH3 EVNH0 OEVAL OEVL1 EVAL EVAL0
SUBTTL EVAL, EVALHOOK, AND EVAL-WHEN
PGBOT EVL
POP3UB: POPI P,1
POP2UB: POPI P,2
JRST UNBIND
EVALHOOK:
JSP TT,LWNACK
LA23,,QEVALHOOK
MOVE D,T
JSP T,SPECBIND ;BIND "EVALHOOK" TO LAST ARG
-1←33. 0,VEVALHOOK
CAME D,XC-2
JRST EVNH3
PUSH P,[POP2UB]
MOVE A,-2(P)
JRST EVNH0
EVNH3: PUSH P,[POP3UB]
PUSH P,-3(P)
PUSH P,-3(P)
PUSHJ FXP,AEVAL
EVNH0: SKIPN V.RSET ;EVALUATE, BYPASSING HOOK CHECK
JRST EV0 .SEE STORE
JRST EVAL0
OEVAL: JSP TT,LWNACK ;"EXTERNAL" EVAL - LSUBR (1 . 2)
LA12,,QOEVAL ;MAY TAKE ALIST AS SECOND ARG
AOJE T,OEVL1
PUSH P,[POP2J] ;PHOO! HAVE TO KEEP THE SAME EVALFRAME
PUSH P,-2(P) ;
PUSH P,-2(P)
PUSHJ FXP,AEVAL ;MAKE UP ALIST, POP OFF 2, AND LEAVE ARG IN A
JRST EVAL
OEVL1: POP P,A
EVAL: SKIPN V.RSET ;"INTERNAL" EVAL - ARG IN A
JRST EV0
SKIPN B,VEVALHOOK
JRST EVAL0
JSP T,SPECBIND ;SUPER-RANDOM HACK SO THAT MM
VEVALHOOK ; CAN INVENT A ↑N FOR LISP
CALLF 1,(B)
JRST UNBIND
EVAL0: SKIPE NIL ;RANDOM PLACE TO CHECK FOR NIL CLOBBERED
PUSHJ P,NILBAD
PUSH P,FXP ;EVAL FRAME FORMAT:
HRLM FLP,(P) ; FLP,,FXP
PUSH P,A ; SP,,<FORM>
HRLM SP,(P) ; $EVALFRAME
PUSH P,[$EVALFRAME] ;SEE APPLY FOR FORMAT OF APPLY FRAMES
.SEE L$EVALFRAME
;FALLS THROUGH
;EV0 EV0A EVTB1 EV2 EVTB2
;FALLS IN
;;; EVALUATE A FORM IN A
EV0: JUMPE A,CPOPJ ;NIL => NIL, ALWAYS!!!
MOVEI C,ILIST
SKOTT A,LS
2DIF JRST (TT),EVTB1-1,QLIST .SEE STDISP
EV0A: MOVE AR1,(A) ;FUNCTION ON 0(P), ADDRESS TO JRST TO IN (TT)
HLRZ T,(A)
SKOTT T,LS
2DIF JRST (TT),EVTB2-1,QLIST .SEE STDISP
HLRZ TT,(T)
CAIN TT,QLAMBDA
JRST EXP3
CAIE TT,QFUNARG
CAIN TT,QLABEL
JRST EXP3
JUMPL C,EV3B
SKIPE B,VOEVAL
JCALLF 1,(B) ;EVALSHUNT
HLRZ A,AR1
TLNN C,777740 ;MAYBE SAVE FUNCTION NAME IN EV0B
MOVEM A,EV0B
PUSH P,EV0B ;NON-ATOMIC FUNCTION, NOT LAMBDA,
PUSH P,C ; LABEL, OR FUNARG
PUSH P,AR1
PUSHJ P,EV0 ;SO EVALUATE THE FORM
POP P,AR1
POP P,C
POP P,EV0B
JRST EV4 ;NOW TRY USING THE RESULT AS A FUNCTION
EVTB1: JRST PDLNKJ ;FIXNUMS EVALUATE TO THEMSELVES
JRST PDLNKJ ;DITTO FLONUMS
DB$ JRST PDLNKJ ;DITTO DOUBLES
CX$ JRST PDLNKJ ;DITTO COMPLEXES
DX$ JRST PDLNKJ ;DITTO DUPLEXES
BG$ POPJ P, ;GUESS WHAT, FELLAHS
JRST EE1 ;SOME HAIR FOR SYMBOLS
HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS (SHOULD BE CAUGHT BEFORE THIS TABLE)
JRST EV2 ;RANDOMS LOSE
POPJ P, ;ARRAYS EVAL TO SELVES
IFN .-EVTB1-NTYPES+1, WARN [WRONG LENGTH TABLE]
EV2: %WTA EMS25 ;UNEVALUABLE DATUM (RANDOMNESS)
JRST EV0
EVTB2: JRST EV3A ;FIXNUM AS A FUNCTION IS AN ERROR
JRST EV3A ;DITTO FLONUM
DB$ JRST EV3A ;DITTO DOUBLE
CX$ JRST EV3A ;DITTO COMPLEX
DX$ JRST EV3A ;DITTO DUPLEX
BG$ JRST EV3A ;DITTO BIGNUM
JRST EE2 ;SYMBOLS - THE GOOD CASE
HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS
JRST EV3A ;IT'S A TRULY RANDOM FUNCTION!
JRST ESAR ;IT'S AN ARRAY
IFN .-EVTB2-NTYPES+1, WARN [WRONG LENGTH TABLE]
;EE1 EE2 EE2A ETT EAL EAL2 EFM EFMER
EE1: PUSHJ P,EVSYM ;EVALUATE SYMBOL
POPJ P, ;WIN
JRST EV0 ;LOSE - RETRY
EE2: SETZ R, ;ZERO R FOR HACK TO TRAP AUTOLOAD LOSS
EE2A: HRRZ T,(T) ;CAR (X) IS ATOMIC
JUMPE T,EAL2 ;GET FUNCTION DEFINITION OFF ATOM
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY ;SYMBOL HEADERS FOR FUNCTION MARKERS
CAILE TT,QAUTOLOAD ; ARE LINEAR IN MEMORY
JRST EE2A
2DIF JRST @(TT),ETT,QARRAY
ETT: EAR ;ARRAY
ESB ;SUBR
EFS ;FSUBR
ELSB ;LSUBR
AEXP ;EXPR
EFX ;FEXPR
EFM ;MACRO
EAL ;AUTOLOAD
EAL: HRRI R,(T) ;NOTE THAT WE SAW AUTOLOAD PROPERTY
JRST EE2A
EAL2: JUMPL R,EV3J ;FN UNDEF AFTER AUTOLOAD
JUMPE R,EV3 ;NO AUTOLOAD PROP - TRY EVALING ATOM
MOVEI B,(R)
HLRZ T,(A)
PUSHJ P,IIAL
HLRZ T,(A)
SETO R,
JRST EE2A
EFM: CAIE C,ILIST ;FOUND MACRO
EFMER: LERR EMS21 ;IMPROPER USE OF MACRO
MOVE B,AR1
HLRZ AR1,(T) ;COMMENT THIS CROCK
CAIN A,AR1
PUSHJ P,CONS1
CALLF 1,(AR1) ;SO HAND THE FORM TO THE MACRO
JRST EVAL ; AND RE-EVALUATE THE RESULT
;EFX AEXP EXP3 CIAPPLY EFS ELSB ELSB1 ESAR EAR EAR3 EAR1
EFX: HLRZ T,(T) ;FOUND FEXPR
HLL T,AR1 ;SO A FEXPR BEHAVES LIKE AN EXPR
PUSH P,T ; WHOSE ONE ARG IS CDR OF THE FORM
HRLI AR1,400000 .SEE IAP4 ;FOR EXPLANATION OF THIS HACK
PUSH P,AR1 ; WHICH ALLOWS FEXPRS AN ALIST ARG
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T) ;FOUND EXPR
HLL T,AR1
EXP3: PUSH P,T ;FOUND LAMBDA, LABEL, FUNARG
MOVEI A,(AR1)
CIAPPLY:
MOVEI TT,IAPPLY
JRST (C)
EFS: HLRZ T,(T) ;FOUND FSUBR
MOVEI C,ESB3 ;THIS IS SO WE DON'T EVAL THE ARGS!
JRST ESB2
ELSB: PUSH P,CPOPJ ;FOUND LSUBR
HLLM AR1,(P)
MOVE R,T
HLL R,AR1
MOVEI TT,ELSB1
HRRZ A,AR1
JRST (C)
ELSB1: MOVEI A,NIL ;A HAS NIL WHEN ENTERING AN LSUBR
HLRZ D,(R)
SKIPN V.RSET
JRST (D)
HLRZ R,R
PUSHJ P,ARGCK0 ;CHECK OUT NUMBER OF ARGS
JRST ESB6
JRST (D)
ESAR: SKIPA TT,T ;FOUND SAR
EAR: HLRZ TT,(T) ;FOUND ARRAY
MOVEI R,(TT)
SKOTT TT,SA
JRST EV3A
EAR3: HRRZ T,ASAR(R)
CAIN T,ADEAD
JRST EV3A ;AHA! THIS ARRAY IS DEAD!
PUSH P,R
MOVEI T,EAR1 ;MUST DO SOME HAIR SO THAT
JRST ESB4 ; INTERRUPTS WON'T SCREW US
EAR1: MOVE T,LISAR ;DO NOT MERGE THIS WITH IAPAR1
JRST @ASAR(T) .SEE ESB3
;ESB ESB4 ESB2 ESB1 ESB3 ESB3A ESB3C EV3 EV4 EV4B EWHEN
ESB: HLRZ R,AR1 ;FOUND SUBR
HLRZ T,(T)
ESB4: MOVEI TT,ESB1
ESB2: MOVEI A,(AR1) ;A GETS LIST OF ARGS
HLL T,AR1
PUSH P,T ;STORE ADDRESS OF SUBROUTINE FOR FN
JRST (C) ;GO SOMEWHERE OR OTHER
ESB1: PUSHJ P,ARGCHK
JRST ESB6
MOVE TT,[A,,A+1]
MOVEI A,Q..MIS
BLT TT,A+NACS-1
JSP R,PDLA2(T)
ESB3: HRRZ TT,(P)
CAIN TT,EAR1 ;HACK TO HELP EAR1 WIN
JRST ESB3C
ESB3A: SKIPN V.RSET
POPJ P, ;ADDRESS OF SUBR IS ON STACK
MOVEI TT,CPOPJ ;WELL, MAYBE DO SOME *RSET HAIR
HLL TT,(P)
EXCH TT,(P)
JRST (TT)
ESB3C: HRRZ TT,-1(P)
MOVEM TT,LISAR ;SAR PROTECTED BY BEING IN LISAR
POP P,-1(P)
JRST ESB3A
EV3: SKIPE EVPUNT ;PUNT EVALUATION OF SYMBOL?
JRST EV3A
JUMPL C,EV3B ;C<0 => TOO MANY RE-EVALS OF A FN
HLRZ A,AR1
HLRZ A,(A)
HRRZ A,@(A) ;GET VALUE OF ATOMIC FUNCTION
CAIN A,QUNBOUND ;IT'S UNBOUND. LOSE, LOSE, LOSE...
JRST EV3A
TLNN C,777740 ;SAVE FN NAME IN EV0B, MAYBE
HLRZM AR1,EV0B
EV4: ADD C,[1←34.] ;THIS SIZE OF THIS QUANTITY CONSTRAINS
EV4B: HRL AR1,A ; THE # OF TIMES WE MAY RE-EVAL THE FN
MOVEI A,AR1
JRST EV0A
;;; (EVAL-WHEN (. . . EVAL . . .) e1 e2 . . . en) does a progn on
;;; the ei, and returns non-null only if the evaluations were done.
;;; The context combined with the first arg list determines if any
;;; thing is done - if there is EVAL in this list, then the progn
;;; is done.
EWHEN: HRRZ C,(A)
SKOTT C,LS
JRST FALSE
PUSH P,C
HLRZ B,(A)
MOVEI A,QOEVAL
PUSHJ P,MEMQ1
POP P,B
JUMPE A,CPOPJ
PUSHJ P,IPROGN
JRST TRUE
;SYMEV0 SYMEVAL EVSYM EE1A
SUBTTL SYMEVAL
SYMEV0: %WTA NASER
SYMEVAL: JUMPE A,CPOPJ ;SUBR 1
JSP T,SPATOM
JRST SYMEV0
PUSHJ P,EVSYM
POPJ P, ;WON
JRST SYMEVAL ;LOST
;;; EVALUATE ATOMIC SYMBOL. SKIPS ON FAILURE (AFTER DOING ERROR).
EVSYM: HLRZ T,(A) ;T GETS POINTER TO SYMBOL BLOCK
HRRZ T,@(T) ;AR1 GETS VALUE FROM VALUE CELL!!!
CAIN T,QUNBOUND
JRST EE1A ;FOOBAR! VALUE CELL CONTAINS UNBOUND
MOVEI A,(T) ;SO THE VALUE IS THE RESULT OF EVAL
POPJ P,
EE1A: %UBV MES6 ;UNBOUND VAR
JRST POPJ1
;;; END OF EVSYM ROUTINE
;APPLY APPWT1 .APPLY AP3 AP3A APPWTA AP2 AP4
SUBTTL APPLY, *APPLY, SUBRCALL, LSUBRCALL, ARRAYCALL, FUNCALL
APPLY: CAME T,XC-2 ;"EXTERNAL" APPLY - SUBR (2 . 3)
JRST AP4 ;MAY TAKE A THIRD ALIST ARG
JSP R,PDLA2(T)
APPWT1: JUMPE B,AP3 ;ALLOW NIL AS SECOND ARG
SKOTT B,LS ;SECOND ARG TO APPLY MUST BE A LIST
JRST APPWTA
.APPLY: ;SUBR 2 (*APPLY)
AP3: SKIPN V.RSET
JRST AP3A
PUSH P,B
PUSH P,FXP
HRLM FLP,(P)
PUSH P,A
HRLM SP,(P)
PUSH P,[$APPLYFRAME]
AP3A: MOVEI AR1,(B) ;"INTERNAL" APPLY -
HRL AR1,A ; FUNCTION IN A, LIST OF ARGS IN B
MOVEI A,AR1
MOVEI C,AP2 ;THIS CROCK LETS US SHARE CODE WITH
JRST EV0A ; EVAL BY PREVENTING EVAL'ING OF ARGS
APPWTA: EXCH A,B
WTA [MUST BE A LIST -- APPLY!]
EXCH A,B
JRST APPWT1
AP2: MOVEI T,0 ;DE-LISTIFY THE ARGS AND STACK THEM
JUMPE A,(TT) ; ON THE PDL, AND ALSO COUNT THEM
PUSH P,(A) ;DOING THINGS THIS WAY AVOIDS
HLRZS (P) ; DESTROYING ANY OTHER ACS
HRRZ A,(A)
SOJA T,.-4
AP4: JSP TT,LWNACK ;APPLY WITH AN ALIST (GOOD GRIEF!)
LA23,,QAPPLY
MOVEM T,APFNG1
SKIPE A,(P) ;PURPOSELY CRIPPLING THE POWER OF
JSP T,FXNV1 ; THE ALIST ROUTINE: FOOEY! - GLS
PUSHJ P,ALIST ;SO CREATE MORONIC ALIST ENVIRONMENT
EXCH T,APFNG1
JSP R,PDLA2(T)
SKIPE APFNG1 ;ALIST RETURNING NON-ZERO IN T =>
PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED
PUSH P,CAUNBIND
JRST AP3
;SUBRCALL RETTYP %LSUBRCALL PTRCHK
SUBRCALL:
JSP TT,FWNACK ;LSUBR (2 . 7)
FA234567,,QSUBRCALL
JSP TT,JLIST
ADDI T,1
JSP R,PDLARG
POP P,TT
JSP D,PTRCHK
PUSHJ P,(TT)
RETTYP: POP P,D ;PURELY FOR TYPE CHECKING
CAIN D,QFIXNUM
JSP T,FXNV1
CAIN D,QFLONUM
JSP T,FLNV1
POPJ P,
%LSUBRCALL:
JSP TT,FWNACK ;FSUBR
FA2N,,Q%LSUBRCALL
JSP TT,JLIST
MOVEI D,(P)
ADDI D,(T)
MOVEI TT,RETTYP
EXCH TT,1(D)
JSP D,PTRCHK
AOJA T,(TT)
PTRCHK: CAIL TT,BEGFUN
CAIL TT,ENDFUN
JRST .+2
JRST (D)
CAML TT,BPSL
CAML TT,@VBPORG
JRST PTRCKE
JRST (D)
;%ARRAYCALL %ARR7 FUNCALL FUNCA1
%ARRAYCALL:
JSP TT,FWNACK ;FSUBR
FA76543,,Q%ARRAYCALL
JSP TT,JLIST
MOVEI D,(T)
ADDI D,(P) ;FALLS INTO FUNCALL
%ARR7: HRRZ A,1(D)
SKOTT A,SA
SOJA T,%ARR0
MOVEI B,CPOPJ
EXCH B,(D)
HLRZ TT,@1(D) .SEE ASAR
MOVEI F,AS<SX>
CAIN B,QFIXNUM
MOVEI F,AS<FX>
CAIN B,QFLONUM
MOVEI F,AS<FL>
TRNN TT,(F)
JRST %ARR0A
FUNCALL: MOVEI D,QFUNCALL ;LSUBR (1 . 777)
JUMPE T,WNALOSE ;(FUNCALL F X1 X2 ... XN) IS LIKE
FUNCA1: SKIPN V.RSET ; (APPLY F (LIST X1 X2 ... XN))
AOJA T,IAPPLY ;IN *RSET MODE, WE FAKE
ADDI T,1 ; OUT THE UUO STUFF
MOVEI TT,(P) ; INTO DOING THE APPLY
ADDI TT,(T) ; FRAME HACKERY FOR US
MOVEI B,CPOPJ
EXCH B,(TT)
JCALLF 16,(B)
;IAPPLY ILP1 ILP1B
;;; VERY INTERNAL APPLY, FOR USE PARTICULARLY WITH "CALL" UUO'S
;;;
;;; STATE OF WORLD AT ENTRANCE TO IAPPLY:
;;; T HAS -<NUMBER OF ARGS ON PDL>.
;;; PDL HAS ARGS ON IT; BELOW THEM IS A SLOT
;;; WITH THE FUNCTION IN THE RIGHT HALF.
;;; THE FUNCTION'S NAME IS MAYBE IN THE LEFT HALF.
;;; C IS USED PRIMARILY TO POINT TO THIS LATTER SLOT; AND, AS
;;; USUAL, THE LEFT HALF HELPS TO LIMIT FUNCTION RE-EVALS.
;;; IF THERE IS ONLY ONE ARG ON THE STACK, 400000 IN THE LEFT
;;; HALF OF THE PDL SLOT MEANS FUNCTION IS A FEXPR, AND MAY
;;; THEREFORE TAKE AN EXTRA (A-LIST) ARGUMENT.
IAPPLY: MOVE C,T ;STATE OF WORLD AT ENTRANCE:
ADDI C,(P) ; T HAS -<NUMBER OF ARGS ON PDL>
ILP1: HRRZ A,(C) ; NEXT PDL SLOT HAS FUNCTION IN RH,
SKOTT A,LS
2DIF JRST (TT),APTB1-1,QLIST ;FN IS NOT LIST STRUCTURE
HRRZ B,(A)
HLRZ A,(A)
CAIN A,QLAMBDA
JRST IAPLMB ;IT'S A LAMBDA
CAIN A,QFUNARG
JRST APFNG ;IT'S A FUNARG (MORE GOOD GRIEF!)
CAIN A,QLABEL
JRST APLBL ;IT'S A LABEL (SUPER GOOD GRIEF!)
PUSH P,C
PUSH FXP,T
HRRZ A,(C)
JUMPL C,IAP2A ;JUMP IF WE'VE RE-EVAL'ED TOO MUCH
PUSHJ P,EV0 ;ELSE EVAL THE FUNCTIONAL FORM
POP P,C ; AND TRY IT AGAIN...
POP FXP,T
ILP1B: MOVE B,(C)
HRRM A,(C)
TLNN B,-1
HRLM B,(C) ;PUTS FUNCTION NAME IN LH IF NOT THERE
TLO C,400000
JRST ILP1
;APTB1 IAPATM IAPAT2 IAPAT3 IATT IAPIAL IAPIA1 IIAL IAPSAR IAPARR IAPSBR IAPSB1 IAPAR1
APTB1: JRST IAP2A ;FIXNUMS ARE NOT FUNCTIONS!
JRST IAP2A ;NOR FLONUMS
DB$ JRST IAP2A ;NOR DOUBLES
CX$ JRST IAP2A ;NOR COMPLEXES
DX$ JRST IAP2A ;NOR DUPLEXES
BG$ JRST IAP2A ;NOR BIGNUMS ALREADY
JRST IAPATM ;SYMBOLS ARE OKAY, BUT JUST BARELY
HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS
JRST IAP2A ;TRUE RANDOMS ARE OUT!
JRST IAPSAR ;IT'S AN ARRAY - OKAY, I GUESS
IAPATM: HRRZ B,(A) ;APPLY GOT ATOMIC FUNCTION
HRRZS 1(C) ;KILL POSSIBLE 400000 BIT DUE TO FEXPR
TDZA R,R
IAPAT2: HRRZ B,(B)
IAPAT3: JUMPE B,IAPIA1 ;GRAB FUNCTION FROM PROP LIST
HLRZ TT,(B)
HRRZ B,(B)
CAIL TT,QARRAY ;REMEMBER, FUNCTION PROPS ARE
CAILE TT,QAUTOLOAD ; LINEAR IN MEMORY
JRST IAPAT2
2DIF JRST @(TT),IATT,QARRAY
IATT: IAPARR ;ARRAY
IAPSBR ;SUBR
IAPSBR ;FSUBR
IAPLSB ;LSUBR
IAPXPR ;EXPR
IAPXPR ;FEXPR
IAPAT2 ;IGNORE MACROS
IAPIAL ;AUTOLOAD
IAPIAL: HRRI R,(B)
JRST IAPAT2
IAPIA1: JUMPL R,IAP2J
JUMPE R,IAP2
MOVEI B,(R)
MOVEI T,(A)
PUSHJ P,IIAL
HRRZ B,(A)
SETO R,
JRST IAPAT3
IIAL: PUSH P,A
HLRZ A,(B)
PUSHJ P,AUTOLOAD
JRST POPAJ
IAPSAR: SKIPA TT,A ;APPLY A SAR
IAPARR: HLRZ TT,(B) ;APPLY AN ARRAY
MOVEM TT,LISAR ;FOR INTERRUPT PROTECTION ONLY
MOVEI R,(T)
MOVEI TT,IAPAR1
JRST IAPSB1
IAPSBR: HLRZ TT,(B) ;APPLY A SUBR
HRRZ R,(C)
IAPSB1: HRRM TT,(C)
JRST ESB1
IAPAR1: MOVE TT,LISAR
JRST @ASAR(TT)
;IAPXPR IAPLSB IAP2
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAPLSB: MOVEI TT,CPOPJ
HRRM TT,(C)
MOVE R,B
JRST ELSB1
IAP2: SKIPE EVPUNT ;DON'T EVALUATE FUNCTIONAL VARIABLE?
JRST IAP2A
JUMPL C,IAP2A
HRRZ A,(C) ;APPLY FUNCTIONAL FROM VALUE CELL
HLRZ A,(A)
HRRZ A,@(A)
CAIE A,QUNBOUND ;FOOBAR! IT'S UNBOUND
JRST ILP1B
JRST IAP2A
;IAPLMB IPLMB1 IAP5 IAP5C IAP5B IPLMB2 IPLMB4 IPLM4A IPLM4B IPLMB5 LMBLP LMBLP1 LMBLP2 IPROGN IAP3 CUNBIN IAP4
IAPLMB: HLRZ TT,(B) ;APPLY A LAMBDA EXPRESSION
MOVEI D,(TT)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNE D,SY
JUMPN TT,IAP3
SETZ D, ;IMPORTANT THAT D BE NON-NEG - SEE IAP4
MOVEI C,(TT)
HRRZ B,(B)
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;NO MORE ARGS
JUMPE TT,QF2A ;TOO MANY ARGS SUPPLIED
IAP5: HLRZ A,(TT)
SKIPE V.RSET
JUMPN A,IAP5C
IAP5C: MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1) ;SEE COMMENT AT EFX - ALLOWS
HRLM A,(AR1) ; A FEXPR TO TAKE AN A-LIST ARG
HRRZ TT,(TT)
AOJA T,IPLMB1
IAP5B: MOVEI D,(A)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,SY
JRST LMBERR
JRST IAP5C
IPLMB2: JUMPN TT,IAP4 ;TOO FEW ARGS SUPPLIED
JUMPN R,IPLMB4 ;NO LAMBDA LIST IN FUN
POP P,TT
HRRI TT,CPOPJ ;LAMBDA LIST IS NULL
SKIPE V.RSET
PUSH P,TT
HRRZ A,(B)
JUMPN A,LMBLP
HLRZ A,(B)
JRST EVAL
IPLMB4: MOVEM SP,SPSV
SKIPA
IPLM4A: PUSHJ P,BIND ;BIND VALUES TO LAMBDA VARS
IPLM4B: POP P,AR1 ;FUN HAS A NON-NL LAMBDA LIST
HLRZ A,AR1
SKIPE A ;IF NIL AS VARIABLE, DON'T BIND THIS ARG
AOJLE R,IPLM4A ;TO BIND A NON-NIL VARIABLE
AOJLE R,IPLM4B ;THIS WINS EVEN IF PREVIOUS INS DOESN'T JUMP
SKIPN V.RSET
JRST IPLMB5
HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
IPLMB5: JSP T,SPECX
HRRZ AR1,(B)
PUSH P,CUNBIND
HLRZ A,(B)
JUMPE AR1,EVAL ;A GENERALIZED LAMBDA: NON-NULL LAMBDA LIST
LMBLP: PUSH P,B ;FOR GENERAL LAMBDAS, EVALS SEQUENCE OF EXP'S
HLRZ A,(B)
PUSHJ P,EVAL
LMBLP1: POP P,B
HRRZ B,(B)
LMBLP2: JUMPN B,LMBLP
POPJ P,
IPROGN: MOVEI A,NIL ;INTERNAL PROGN
JRST LMBLP2
IAP3: MOVEI A,(TT) ;APPLY LEXPR
MOVN TT,T
CAIL TT,XHINUM
JRST LXPRLZ
MOVEI AR1,CPOPJ
HRRM AR1,(C)
MOVEI AR1,IN0(TT)
MOVEM SP,SPSV
PUSHJ P,BIND
MOVEI C,(C)
EXCH C,ARGLOC
HRLI C,ARGLOC
PUSH SP,C ;BIND ARGLOC TO LOC OF ARGS ON PDL
EXCH AR1,ARGNUM
HRLI AR1,ARGNUM
PUSH SP,AR1 ;BIND ARGNUM TO NUMBER OF ARGS
JSP T,SPECX
HRRZ B,(B)
PUSHJ P,LMBLP
SKIPN T,@ARGNUM
JRST UNBIND
HRLS T
SUB P,T
JRST UNBIND
CUNBIN: JRST UNBIND
IAP4: JUMPGE D,QF3A
AOJN R,QF3A
JRST IAP4A ;FEXPR OF TWO ARGS
SUBTTL FUNCTION, QUOTE, DECLARE, COMMENT, SETQ, AND, OR
;FUNCTION QUOTE DECLARE $COMMENT SETQ SET1 $AND $OR ANDOR
FUNCTION: SKIPA D,CQFUNCTION ;FEXPR 1
QUOTE: MOVEI D,QQUOTE ;FEXPR 1
JUMPE A,WNAFOSE
HRRZ TT,(A)
JUMPE TT,$CAR
JRST WNAFOSE
DECLARE: MOVEI A,QDECLARE ;FSUBR (IGNORES ARG)
POPJ P,
$COMMENT: MOVEI A,Q$COMMENT ;FSUBR (IGNORES ARG)
POPJ P,
SETQ: PUSH P,A
SET1: HLRZ A,@(P)
JSP D,SETCK
HRRZ B,@(P)
JUMPE B,SETWNA
PUSH P,A ;ATOM TO BE SETQD
HLRZ A,(B)
HRRZ B,(B)
MOVEM B,-1(P)
PUSHJ P,EVAL
POP P,AR1
JSP T,.SET
SKIPE (P)
JRST SET1
JRST POP1J
$AND: HRLI A,TRUTH
$OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,POPAJ
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST POPAJ
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
;PROG PRG1 PRG1Z PG0 LPRP PG1 PG1A PG0A VBIND PBIND PBIND1 PBIND2 PROGV RETURN PRXIT ERRP4 RHAPJ CQFUNCTION
SUBTTL PROG, PROGV, RETURN, GO
PROG: HLRZ AR2A,(A) ;FSUBR
HRRZ A,(A)
PRG1: JUMPE AR2A,PRG1Z ;EITHER THEY ARE NIL OR
SKOTT AR2A,LS ; MUST HAVE A LIST FOR PROG VARS
JRST PRGER1
PRG1Z: PUSH P,A
SETZ C,
JSP T,PBIND ;BIND PROG VARIABLES TO NIL
POP P,A
PUSHJ P,PG0 ;EVALUATE PROG BODY
MOVEI A,NIL
JRST UNBIND ;UNBIND VARIABLES
PG0: PUSH P,PA3
PUSH P,PA4
PUSH P,SP
PUSH P,FXP
PUSH P,FLP
LPRP==.-PG0+1 ;LENGTH OF PROG PDL, IE HOW MUCH PROG HAS
MOVEM P,PA4 ;CAUSED TO BE PUSHED
HRLS A
MOVEM A,PA3
PG1: HLRZ T,PA3
PG1A: JUMPE T,PRXIT ;NORMAL EXIT
HLRZ A,(T)
HRRZ T,(T)
HRLM T,PA3
SKOTT A,LS
JRST PG1
PUSHJ P,EVAL
PG0A: JRST PG1
;;; JSP T,VBIND ;LIST OF SYMBOLS IN AR2A, VALUES IN A
;;; BINDS EACH SPECIAL VARIABLE IN THE LIST TO CORRESPODNING VALUES.
;;; IF VALUES LIST TOO SHORT, "UNBOUND" GETS USED FOR PROGV, AND
;;; NIL OTHERWISE.
VBIND: MOVEI C,(A) ;INTERPRETED AND COMPILED PROGV COME HERE
SKIPA R,[QUNBOUND] ;USE UNBOUND AS VALUE OF EXTRA VARIABLES
PBIND: MOVEI R,NIL ;USE NIL AS VALUE OF EXTRA VARS
MOVEM SP,SPSV ;BIND PROG VARIABLES
JUMPE AR2A,SPECX
MOVEI AR1,NIL
PBIND1: HLRZ A,(AR2A) ;NEXT VARIABLE
HLRZ AR1,(C) ;NEXT VALUE
SKIPN C ;HAVE WE RUN OFF THE END OF THE LIST?
MOVEI AR1,(R) ;YES, USE DEFAULT VALUE
SKOTT A,SY
JRST PBIND2
CAIE A,TRUTH ;DONT BIND NON-SYMBOLS, NOR "T"
PUSHJ P,BIND
PBIND2: HRRZ C,(C)
HRRZ AR2A,(AR2A)
JUMPN AR2A,PBIND1
JRST SPECX
PROGV: HRRZ B,(A) ;FSUBR
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
PUSH P,C
PUSH P,B
PUSHJ P,EVAL ;GET LIST OF VARIABLES
EXCH A,(P)
PUSHJ P,EVAL ;GET LIST OF VALUES
POP P,AR2A
JSP T,VBIND ;BIND VARIABLES
POP P,B
PUSHJ P,LMBLP ;EVAL REST LIKE LAMBDA BODY
JRST UNBIND
RETURN: JSP T,BKERST ;SUBR 1
MOVE P,PA4
AOS -LPRP+1(P) ;RETURN CAUSES SKIP
PRXIT: POP P,FLP ;PROG EXIT
POP P,FXP
POP P,TT
PUSHJ P,UBD0
POP P,PA4
ERRP4: POP P,PA3
RHAPJ: MOVEI A,(A)
CQFUNCTION: POPJ P,QFUNCTION
;GO GO2 GO1 PG5 PG5A GO3 GO3B GO3A
GO: JSP TT,FWNACK
FA1,,QGO
HLRZ A,(A)
GO2: JSP T,SPATOM ;LEAVES TYPE BITS IN TT
JRST GO3
GO1: JSP T,BKERST
HRRZ T,PA3
PG5: JUMPE T,EG1
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,(A)
JRST PG5A
TLNN A,400000 ;4.9 BIT => GO TAG IS NUMERIC
JRST PG5
MOVEI D,(TT)
LSH D,-SEGLOG
SKIPL D,ST(D)
TLNN D,FX+FL
JRST PG5
MOVE TT,(TT)
CAME TT,(A)
JRST PG5
PG5A: MOVE P,PA4
MOVE FLP,(P)
MOVE FXP,-1(P)
HRRZ TT,-2(P)
PUSHJ P,UBD
JRST PG1A
GO3: TLNN TT,FX+FL
JRST GO3A
GO3B: MOVE TT,(A) ;SET 4.9 BIT OF A IF TAG IS NUMERIC
CAML TT,[-XLONUM]
CAIL TT,XHINUM ; BUT NOT INUM
TLO A,400000
JRST GO1
GO3A: PUSHJ P,EVAL ;IF ARG TO GO ISN'T ATOMIC, DO ONE EVAL AND TRY AGAIN
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,FX+FL
JRST GO3B
TLNE TT,SY
JRST GO1
JRST EG1
;DO DO4A DO4 DO4C DO7 DO7A DO9
SUBTTL DO FUNCTION
DO: PUSH P,PA4
SETZM PA4
PUSH FXP,R70 ;A "DO SWITCH" TO MARK EXPANDED FORMAT
PUSH P,A
HLRZ A,(A)
SKOTT A,LS ;HUNKS WIN AS WELL AS LISTS
JUMPN A,DO4A
HRROM A,(FXP)
HLRZ A,@(P) ;SETUP FOR MULTIPLE INDICES
HRRZ C,@(P)
HLRZ B,(C)
JRST DO4
DO4A: MOVE A,(P) ;SINGLE INDEX DO
HRRZ B,(A)
HRRZ B,(B)
HRRZ B,(B)
MOVE C,B
DO4: HRRZ C,(C)
MOVEM A,(P) ; (P) PROG BODY
DO4C: SKOTT B,LS
JUMPN B,DOERRE
PUSH P,B ; -1(P) ENDTEST
PUSH P,C ; -2(P) DO VARS LIST
MOVE A,-2(P)
MOVSI R,600000 ;EVALUATE AND SETUP INITIAL VALUES
SKIPN -1(P)
MOVSI R,400000 ;200000 BIT SAYS STEPPERS ARE OKAY
PUSHJ FXP,DO5
SKIPN -1(P)
JRST DO4D
DO7: HLRZ A,@-1(P)
PUSHJ P,EVAL
JUMPN A,DO8
DO7A: MOVE A,(P)
PUSHJ P,PG0 ;DO PROG BODY (MAY SKIP ON RETURN STATEMENT)
JRST DO2
DO9: MOVE B,-2(P)
SUB P,R70+3 ;BREAK OUT OF BODY BY RETURN STATEMENT
POP P,PA4
SUB FXP,R70+1
JUMPN B,UNBIND
POPJ P,
;DO8 DO2 DO4D DO5 DO5Q DO5Q1 DO5F DO5B
DO8: SKIPN A,(FXP)
JRST DO9 ;SIMPLE DO FORMAT
HRRZ B,@-1(P) ;DO PASSED ENDTEST, AND RETURNS A VALUE
PUSHJ P,IPROGN
JRST DO9
DO2: MOVE A,-2(P)
MOVEI R,0 ;DO STEPPING FUNCTIONS
PUSHJ FXP,DO5
JRST DO7
DO4D: MOVE A,(P)
PUSHJ P,PG0
SETZ A, ;DEFAULT VALUE OF ONCE-THROUGH DO IS NIL
JRST DO9
DO5: JUMPE A,DO6 ;DOES PARALLEL SETQS - ON LISTS LIKE (I V1 V2)
PUSH P,A ;WILL DO (SETQ I V1) IF R < 0
SKIPE -1(FXP) ;WILL DO (SETQ I V2) IF R > 0
HLRZ A,(A) ;IF DOSW SAYS SINGLE INDEX, THEN ONLY ONE LIST
DO5Q: MOVEI B,(A)
JUMPGE R,DO5F
SKOTT A,SY ;A SINGLETON SYMBOL
JRST DO5Q1 ;NOPE. TRY FURTHUR CHECKS
HRLZS A ;TREAT AS (<SYMBOL> NIL)
EXCH A,(P)
JRST DO5C
DO5Q1: SKOTT A,LS
JRST DOERR
HLRZ A,(B)
JSP T,SPATOM
JRST DOERR
TLNE R,200000
JRST DO5F
HRRZ A,(B)
JUMPE A,DO5F
HRRZ A,(A)
JUMPN A,DO5ER
DO5F: HLRZ A,(B)
HRLM A,(P)
HRRZ A,(B)
JUMPL R,DO5E
JUMPE A,DO5B
HRRZ A,(A)
JUMPN A,DO5D
DO5B: POP P,A
SOJA R,DO5C
;DO5E DO5D DO5G DO5C DO6 DO6A DO6C
DO5E: JUMPE A,DO5G ;(I) IS SAME AS (I NIL) ON INITIAL VALUE
DO5D: HLRZ A,(A)
PUSH FXP,R
PUSHJ P,EVAL
POP FXP,R
DO5G: HLL A,(P)
EXCH A,(P) ;NOW (P) HAS ATOM,,VALUE
DO5C: HRRZ A,(A)
SKIPN -1(FXP)
MOVEI A,0 ;SO THAT SINGLE FORMAT DO WILL DROP OUT
AOJA R,DO5
DO6: TRNN R,-1 ;[(SETQ I V1) FROM ABOVE]
POPJ FXP, ;FIRST TIME THROUGH, WE ALLOW OLD BINDINGS
JUMPGE R,DO6C ;TO BE REMEMBERED ON THE SPDL FOR UNBINDING
HRRZS R
MOVEM SP,SPSV
DO6A: POP P,AR1
HLRZ A,AR1
PUSHJ P,BIND
SOJG R,DO6A
JSP T,SPECX
POPJ FXP,
DO6C: POP P,AR1 ;DURING THE STEPPING PHASE, AS OPPOSED TO
HLRZ A,AR1 ;THE INITIALIZATION PHASE, WE LET NO BINDINGS
PUSHJ P,BIND ;ACCUMULATE ON THE SPDL
JSP T,SETXIT
SOJG R,DO6C
POPJ FXP,
;COND1 COND CON3 COND2 CON2 BKERST BKRST3 BKRST4 BKRST0 BKRST2 BKRST1
SUBTTL COND, ERRSET, ERR, CATCH, THROW, CASE, IF, *CATCH, *THROW,
; UNWIND-PROTECT, CATCHALL, CATCH-BARRIER
COND1: HRRZ A,(B)
COND: JUMPE A,CPOPJ ;ENTRY
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
CAIE A,TRUTH
PUSHJ P,EVAL
CON3: POP P,B
JUMPE A,COND1 ;IF FIRST OF COND PAIR IS TRUE
HLRZ B,(B)
SKIPA
COND2: POP P,B
HRRZ B,(B)
JUMPE B,CPOPJ ;LOOP FOR GENERALIZED COND PAIR
PUSH P,B
HLRZ A,(B)
PUSHJ P,EVAL
CON2: JRST COND2
BKERST: SKIPN TT,PA4
JRST BKRST1
TLZ TT,-1
SKIPE B,CATRTN
JRST BKRST2
BKRST3: SKIPE B,ERRTN
CAILE TT,(B)
JRST (T) ;NO TROUBLESOME CATCHS OR ERRSETS
BKRST4: MOVEI TT,BKERST
BKRST0: MOVEM TT,-LERSTP(B) ;BREAK UP A TROUBLESOME CATCH OR ERRSET, E.G.
HRRZI TT,(B) ;WE WAN'T TO GET RID OF THIS FRAME, HANDLE ALL UNWIND-PROTECTS
; INCLUDING THE FRAME WE WANT TO FLUSH
PUSHJ FXP,UNWPRO
CAILE TT,(P) ;IF P LESS THAN FRAME OF INTEREST, THEN IT WAS AN
; UNWIND-PROTECT FRAME AND UNWPRO THREW IT AWAY. JUST
; RETURN TO OUR CALLER.
JRST (T)
;ELSE THROW THE FRAME AWAY BY HAND
MOVE P,B ;(PROG (A) (ERRSET (RETURN (FOO A))))
JRST ERR1 ;AND THEN TRY BKERST AGAIN
BKRST2: CAILE TT,(B)
JRST BKRST3 ;CATCH ISN'T TROUBLESOME, SO TEST FOR ERRSETS
JRST BKRST4 ;AH, CATCH IS TROUBLESOME!
BKRST1: MOVEI A,LGOR
%FAC EMS22
;ERRSET ERRST3 ERRNX ERR ERR3A ERR3 CATCH .CATCH .CATC1 CATCHB CATCB2 CATCB1 CATCHALL UNWINP UNWERR PTNTRY UNWINC PTEXIT UNWINE THROW .THROW CATHRO
ERRSET: JSP TT,FWNACK
FA12,,QERRSET
MOVEI C,TRUTH
HRRZ B,(A)
JUMPE B,ERRST3
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI C,(A)
POP P,A
ERRST3: JSP T,ERSTP
MOVEM P,ERRTN
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
ERRNX: PUSHJ P,NCONS ;NORMAL EXIT
JRST ERUN0
ERR: JSP TT,FWNACK
FA012,,QERR
JUMPE A,ERR2
HRRZ B,(A)
JUMPE B,.+3
HLRZ B,(B)
JUMPE B,ERR3A
HLRZ A,(A) ;EVAL BEFORE UNBLOCKING
PUSHJ P,EVAL
JRST ERR2
ERR3A: SKIPN ERRTN
JRST LSPRET
MOVEI T,ERR3
EXCH T,-LERSTP(P)
JRST ERR0 ;UNBLOCK THE ERRSET, THEN
ERR3: SKIPE A ;EVAL THE ARG TO ERR
HLRZ A,(A)
PUSH P,T
JRST EVAL
CATCH: JSP TT,FWNACK
FA12,,QCATCH
PUSHJ P,CATHRO
JSP TT,CATPS1
HLRZ A,(B)
PUSHJ P,EVAL
MOVEI B,NIL ;CAUSE MOST RECENT CATCH TO BE THROWN
JRST THROW1
;(*CATCH <tag-or-list-of-tags> e1 . . . en)
; TAG OR TAG-LIST IS EVALUATED. THEN E1 THROUGH EN ARE EVALED. IF A THROW
; OR *THROW IS DONE THEN IS LIKE A REGULAR CATCH.
.CATCH: PUSH P,A ;SAVE POINTER TO ARGS
HLRZ A,(A) ;EVAL TAG/TAG-LIST
PUSHJ P,EVAL
HRLI A,CATSPC\CATLIS ;FLAG IT AS TAG-LIST
SKOTT A,LS ;IS IT A LIST?
HRRZS A ; NO IT ISN'T LIST
.CATC1: POP P,B ;RESTORE POINTER TO ARGS
JSP TT,CATPS1
HRRZ B,(B) ;CDR THE LIST OF ARGS
PUSHJ P,IPROGN ;IMPLICIT PROGN AROUND THEM
JRST THRALL ;THEN BREAK-UP CURRENT CATCH FRAME
; (CATCH-BARRIER <list-of-tags> E1 . . . En)
; LIST-OF-TAGS IS EVALUATED. THEN E1 THROUGH EN ARE EVALED. IF A THROW
; OR *THROW IS DONE THEN IF TAG IS IN LIST-OF-TAGS, THE CATCH-BARRIER RETURNS,
; ELSE AN UNSEEN-CATCH-TAG ERROR IS GENERATED
CATCHB: PUSH P,A ;SAVE POINTER TO ARGS
HLRZ A,(A) ;EVAL TAG/TAG-LIST
PUSHJ P,EVAL
CATCB2: SKOTT A,LS ;IS IT A LIST?
JRST CATCB1 ;NOPE, ERROR
HRLI A,CATSPC\CATLIS\CATCAB ;YES, FLAG CATCH FRAME CORRECTLY
JRST .CATC1 ;REST IS JUST LIKE *CATCH
CATCB1: WTA [MUST BE A LIST OF TAGS - CATCH-BARRIER!]
JRST CATCB2
;(CATCHALL function e1 . . . en)
; FUNCTION IS A FUNCTION OF TWO ARGS. E1 THROUGH EN ARE EVALED, AND IF NO
; THROW IS DONE THE VALUE OF EN IS RETURNED. IF ANY THROW IS DONE, FUNCTION
; IS INVOKED WITH THE FIRST ARG BEING THE THROW TAG AND THE SECOND BEING THE
; THROWN VALUE. THE VALUE OF THE FUNCTION IS THEN RETURNED AS THE VALUE
; OF THE CATCHALL.
CATCHALL:
PUSH P,A ;SAVE POINTER TO ARGS
HLRZ A,(A) ;EVAL FUNCTION
PUSHJ P,EVAL
HRLI A,CATSPC\CATALL ;FLAG AS A CATCHALL
JRST .CATC1 ;REST IS LIKE *CATCH
;(UNWIND-PROTECT e u1 u2 . . . un)
; EXECUTES U1 THRU Un WHEN THE "CONTOUR" OF THE UNWIND-PROTECT IS EXITED.
; IF e TERMINATES NORMALLY, THEN U1 THRU UN ARE EVALUATED AND THE VALUE
; RETURNED BY e IS RETURNED. IF A NON-LOCAL EXIT OCCURS THRU AN UNWIND-PRO
; FRAME, THEN U1 THRU UN ARE EVALED AND THE EXIT CONTINUES.
UNWINP: HRRZ B,(A) ;GET CDR OF ARG LIST
HRLI B,CATUWP\CATSPC ;AN UNWIND-PROTECT FRAME
MOVEM B,CATID
PUSH FXP,P ;SAVE CURRENT STATE OF STACK
JSP T,ERSTP
MOVEM P,CATRTN
HLRZ A,(A) ;CAR OF ARG LIST
PUSHJ P,EVAL ;EVALUATE IT
HRRZ TT,(FXP) ;NOW MUST RUN THE UNWIND PROTECT FUNCTIONS
PUSHJ FXP,UNWPRO ;UNDO THE UNWIND-PROTECT FRAME
POPI FXP,1 ;REMOVE THE SAVED PDL POINTER FROM FXP
POPJ P, ;THEN RETURN THE VALUE OF e
;ERROR TRAP FOR UNWIND-PROTECT, SHOULD NEVER GET HERE!
UNWERR: LERR [SIXBIT \UNWIND-PROTECT LEFT DUMMY RETURN ADR ON STACK!\]
;COMPILED UNWIND-PROTECT, ENTER WITH JSP TT, CONTINUATION IS AT PC C(TT)+1
PTNTRY:
UNWINC: PUSH P,[UNWERR] ;IF GETS HERE, HMM...
AOS TT ;POINT TO START OF CONTINUATION
HRLI TT,CATUWP\CATCOM\CATSPC ;AN UNWIND-PROTECT FRAME
MOVEM TT,CATID
JSP T,ERSTP
MOVEM P,CATRTN
JRST -1(TT) ;RETURN TO COMPILED CODE
;COME HERE TO CLOSE UP AN UNWIND PROTECT. CALLED WITH JSP T,
PTEXIT:
UNWINE: MOVEM TT,-LEP1-4(P) ;SAVE RETURN ADR (AN EXTRA SLOT IS ON P)
MOVEI TT,-LEP1(P) ;ADR TO UNWIND TO
PUSHJ FXP,UNWPRO ;UNDO THE UNWIND-PROTECT FRAME
POPJ P, ;THEN RETURN THE VALUE OF e
;OLD STYLE MACLISP THROW, UNEVALUATED TAG
THROW: JSP TT,FWNACK
FA12,,QTHROW
PUSHJ P,CATHRO
PUSH P,A
HLRZ A,(B)
PUSHJ P,EVAL
POP P,B
JRST THROW1
;(*THROW TAG VAL) SUBR
.THROW: EXCH A,B ;THROW1 WANTS TAG IN B, VAL IN A
JRST THROW1 ;THEN DO A THROW
CATHRO: MOVE B,A
HRRZ A,(A)
JUMPE A,CPOPJ
HLRZ A,(A)
POPJ P,
;CASEQ CASEE CASEF CASES CASE1 CASE1E CASE1H CASE1D CASE1B CASE1A CASE1Z CASE1G CASE1Q CASEBQ CASEBZ CASEM CASECK CASEEQ CASEAQ CASE1C IF IF1A
CASEQ:; TDZA R,R ;FLAG IN R WHETHER CASE/Q
;CASE: SETOI R,
JUMPE A,CPOPJ ;ENTRY, RETURN NIL IF NO ARGS
PUSH P,A ;SAVE POINTER TO ARG LIST
HLRZ A,(A) ;GET EXPRESSION TO MATCH AGAINST
CASEE:; PUSH FXP,R
CAIE A,TRUTH ;FOR SPEED, CHECK FOR SPECIAL KIND
PUSHJ P,EVAL
; POP FXP,R
JUMPE A,CASES ;NIL IS A SYMBOL
MOVE T,A
LSH T,-SEGLOG
MOVE T,ST(T)
TLNE T,FX ;FIXNUM EXPRESSION?
JRST CASEF
TLNE T,SY ;SYMBOL AS EXPRESSION?
JRST CASES
WTA [MATCHING EXPRESSION NOT FIXNUM OR SYMBOL!]
JRST CASEE ;WIN IF USER TRIES AGAIN
CASEF: MOVSI T,FX ;TEST AGAINST FIXNUMS ONLY
JRST CASE1
CASES: MOVSI T,SY ;TEST AGAINST SYMBOLS ONLY
CASE1: POP P,B ;POINTER TO CASE'S ARGUMENTS
PUSH P,A ;EQ TEST AGAINST SYMBOL RETURNED
HRRZ A,(B) ;THE LIST OF MATCHING SETS AND EXPRS
CASE1E: PUSH P,A
HLRZ A,(A) ;THE POINTER TO THE NEXT SET/EXPRS PAIR
HLRZ A,(A) ;THE LIST OF MATCHES OR THE SINGLE MATCH
CASE1H: CAIN A,TRUTH ;IF T THEN AN 'OTHERWISE' CLAUSE
JRST CASEM
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNN TT,LS ;IS THE MATCHING SET A LIST?
JRST CASE1Q ;NO, HANDLE SPECIALLY
CASE1D: PUSH P,A
HLRZ A,(A) ;GET NEXT ELEMENT
CASE1B:;JUMPE R,CASE1A ;DON'T EVALUATE EXPR IF CASEQ
; CAIN A,TRUTH
; JRST CASE1A
; PUSH P,T ;SAVE FLAGS OVER EVAL
; PUSHJ P,EVAL
; POP P,T
; SETO R, ;MAKE SURE FLAG IS STILL CORRECT
CASE1A: TLNE T,SY ;IF TESTING FOR SYMBOLS
JUMPE A,CASE1Z ;THEN NIL IS A VALID ONE
MOVEI TT,(A)
LSH TT,-SEGLOG
TDNN T,ST(TT) ;MATCHING TYPE?
JRST CASE1C
CASE1Z: POP P,B
JSP TT,CASECK ;NON SKIP IF MATCH
JRST CASEM ;MATCH FOUND, PROCESS EXPRESSIONS
HRRZ A,(B) ;GET THE CDR
JUMPN A,CASE1D ;IF MORE MATCHING IN THIS LIST THEN PROCEED
CASE1G: POP P,A ;RESTORE THE LIST OF PAIRS POINTER
HRRZ A,(A) ;THE CDR POINTS TO NEXT CONS
JUMPN A,CASE1E ;IF NOT END OF LIST THEN PROCEED
POPI P,1 ;GET RID OF MATCHING POINTER
POPJ P,
CASE1Q:;JUMPE R,CASEBQ ;IF CASEQ LEAVE UNEVALUATED
; PUSH P,T ;SAVE FLAG
; CAIE A,TRUTH
; PUSHJ P,EVAL
; POP P,T
; SETO R, ;FLAG MUST BE SET IF DID EVAL
CASEBQ: TLNE T,SY ;IF TESTING FOR SYMBOLS
JUMPE A,CASEBZ ;THEN NIL IS A VALID ONE
MOVEI TT,(A) ;TYPE CHECK UNEVALUATED MATCHING ARG
LSH TT,-SEGLOG
TDNN T,ST(TT)
JRST CASEAQ ;NOT MATCH
CASEBZ: JSP TT,CASECK ;NON-SKIP IF MATCH
SKIPA
JRST CASE1G ;MATCH NOT FOUND
CASEM: POP P,A ;GET BACK POINTER TO CONS WITH MATCH
HLRZ A,(A)
MOVEM A,(P) ;CLOBBER MATCHING ARG WITH EXPR LIST
SETZ A, ;MAKE SURE RETURN NIL IF NOTHING TO DO
JRST COND2
CASECK: TLNN T,FX ;USE EQ FOR ATOMS, = FOR FIXNUMS
JRST CASEEQ
MOVE D,(A) ;GET THE FIXNUM
CAME D,@-1(P) ;CHECK USING =
JRST 1(TT) ;SKIP FOR FAILURE
JRST (TT)
CASEEQ: CAME A,-1(P) ;EQ CHECK
JRST 1(TT) ;SKIP FOR FAILURE
JRST (TT)
CASEAQ: WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!]
JRST CASE1H
CASE1C: POP P,A
WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!]
JRST CASE1D
IFN 0,[ ;TEMPORARILY(?) REMOVED
IF: PUSH P,A
HLRZ A,(A) ;TEST EXPRESSION
CAIE A,TRUTH
PUSHJ P,EVAL
POP P,B
HRRZ B,(B)
SKIPN A
JRST IF1A ;FOR FAILURE EVALUATE ALL REMAINING FORMS
HLRZ A,(B)
CAIE A,TRUTH
PUSHJ P,EVAL
POPJ P,
IF1A: PUSH P,B ;COND REQUIRES POINTER TO LIST ON STACK
JRST COND2
];END IFN 0
;$PUSH $PUSH2 $PUSH1 $POP $POP4 $POP5 $POP2 $POP1 $POP3 DISPL0 DISPLACE DISPL2 DISPL1
SUBTTL "SYSTEM" MACROS - SMALL FSUBR'S TO PARELLEL COMPILER MACROS
;;; CURRENTLY: PUSH, POP, DISPLACE
;(DEFUN PUSH FEXPR (X) (SET (CADR X) (CONS (EVAL (CAR X)) (EVAL (CADR X)))))
$PUSH: JSP TT,FWNACK
FA2,,Q$PUSH
PUSH P,A ;SAVE THE ARGUMENT POINTER
HLRZ A,(A) ;GET THE THING TO BE PUSHED
CAIE A,TRUTH
PUSHJ P,EVAL ;EVALUATE IT
EXCH A,(P) ;SAVE THE RESULT, AND GET THE ARG POINTER
HRRZ A,(A)
HLRZ A,(A) ;GET THE SECOND ARGUMENT
$PUSH2: JSP T,LATOM
JRST $PUSH1 ;WRONG TYPE SECOND ARG
PUSH P,A ;SAVE POINTER TO SYMBOL
PUSHJ P,EVSYM ;GET SYMBOL'S VALUE
JFCL ;IF SKIP RETURN USE NEW USER VALUE
MOVE B,-1(P) ;GET THE THING TO BE PUSHED
JSP T,%XCONS ;PUSH ON THE STACK
POP P,AR1 ;GET BACK POINTER TO SYMBOL
JSP T,.SET ;STORE BACK THE NEW STACK POINTER
POPI P,1
POPJ P,
$PUSH1: WTA [STACK NOT ATOM - PUSH!]
JRST $PUSH2
;(DEFUN POP FEXPR (X)
; (PROG2
; (COND ((NULL (CDR X))
; (CAR (EVAL (CAR X))))
; (T (SET (CADR X) (CAR (EVAL (CAR X))))))
; (SET (CAR X) (CDR (EVAL (CAR X))))))
$POP: JSP TT,FWNACK
FA12,,Q$POP
PUSH P,(A) ;SAVE THE FIRST CONS OF THE ARGUMENT LIST
HLRZ A,(A) ;GET THE STACK POINTER
$POP4: SKOTT A,SY ;THE STACK POINTER MUST BE A SYMBOL
JRST $POP1
CAIE A,TRUTH
PUSHJ P,EVAL ;AND GET THE STACK
PUSH P,(A) ;SAVE THE 1ST CONS OF THE STACK ON P
HRRZ A,-1(P) ;GET THE PLACE TO POP INTO
JUMPE A,$POP2 ;NOT SPECIFIED, JUST RETURN THE TOP OF STACK
HLRZ A,(A) ;GET THE CAR
$POP5: SKOTT A,SY
JRST $POP3 ;MUST HAVE A SYMBOL AS THE TARGET OF THE POP
HLRZ AR1,(P) ;CAR OF STACK IS VALUE
JSP T,.SET1 ;SET THE SYMBOL
$POP2: HRRZ AR1,(P) ;NOW CDR THE STACK AND REPLACE INTO STK-PTR
HLRZ A,-1(P)
JSP T,.SET1
HLRZ A,(P) ;RETURN THE CAR OF THE STACK
POPI P,2
POPJ P,
$POP1: WTA [STACK POINTER MUST BE A SYMBOL - POP!]
HRLM A,(P)
JRST $POP4
$POP3: WTA [TARGET OF POP MUST BE A SYMBOL - POP!]
JUMPE A,$POP2
JRST $POP5
;(DEFUN DISPLACE (X Y)
; (AND (ATOM X) (ERROR '|NOT A LIST - DISPLACE| X))
; (COND ((ATOM Y)
; (RPLACA X 'PROGN)
; (RPLACD X (NCONS Y)))
; (T (RPLACA X (CAR Y))
; (RPLACD X (CDR Y)))))
DISPL0: WTA [NOT A LIST - DISPLACE!]
DISPLACE:
MOVEI TT,(A) ;INSURE FIRST ARG IS A LIST
LSH TT,-SEGLOG
SKIPL ST(TT) ;IS IT?
JRST DISPL0
JUMPE B,DISPL2
MOVEI TT,(B) ;CHECK WHETHER SECOND ARG IS LIST OR NOT
LSH TT,-SEGLOG
SKIPL ST(TT) ;LIST?
JRST DISPL1 ;NOPE, SPECIAL TREATMENT
DISPL2: HLRZ AR1,(B) ;CAR Y
HRLM AR1,(A) ;RPLACA X
HRRZ AR1,(B) ;CDR Y
HRRM AR1,(A) ;RPLACD X
POPJ P, ;RETURN X
DISPL1: MOVEI C,QPROGN
HRLM C,(A) ;(RPLACA <1ST-ARG> 'PROGN)
PUSH P,A ;NOW (NCONS <2ND ARG>)
MOVEI A,(B)
PUSHJ P,$NCONS
HRRM A,@(P) ;(RPLACD <1ST-ARG> (NCONS <2ND-ARG>))
POP P,A ;RETURN FIRST ARG
POPJ P,
;STORE STORE7 STORE9 BREAK SIGNP SIGNP0 SPTB
SUBTTL STORE, BREAK, SIGNP
STORE: JSP TT,FWNACK
FA2,,QSTORE
HLRZ B,(A)
PUSH P,B
HRRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL ;EVALUATE SECOND ARGUMENT FIRST!
PUSH P,A
STORE7: HRRZ A,-1(P)
SETZM LISAR
PUSHJ P,EVNH0 ;EVALUATE ARRAY REFERENCE WITHOUT HOOKING IT
SKIPN A,LISAR ;ALWAYS CHECK FOR THIS GROSS LOSS
JRST STORE5
SKIPN V.RSET
JRST STORE9
JSP T,ARYSIZ ;GET SIZE OF ARRAY IN WORDS IN TT
TLNN R,200000 ;=> NEGATIVE INDEX
CAIG TT,(R) ;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE
JRST STORE5
STORE9: POP P,A
SUB P,R70+1
JSP T,.STORE
SETZM LISAR
POPJ P,
BREAK: JSP TT,FWNACK ;FSUBR (1 . 2)
FA12,,QBREAK
HLRZ B,(A) ;BKPT NAME
HRRZ A,(A)
JUMPE A,$BRK0 ;NO SECOND ARG => ALWAYS BREAK
HLRZ A,(A) ;TO-BREAK-OR-NOT SWITCH
PUSH P,B
PUSHJ P,EVAL ;THIS IS A CROCK!!!
POP P,B
JRST $BREAK ;A = BREAKP, B = BREAKID
SIGNP: JSP TT,FWNACK ;FSUBR 2
FA2,,QSIGNP
PUSH P,(A)
HLRZ A,(A)
PUSH P,A
SIGNP0: PUSHJ P,PNGET
HLRZ A,(A)
MOVS T,(A)
HRRZ A,(A)
JUMPN A,SIGNPE
MOVNI A,6
CAIE T,@SPTB+6(A)
AOJL A,.-1
JUMPGE A,SIGNPE
HLLZ A,SPTB+6(A)
SUB P,R70+1
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NUMBERP
JUMPE A,POP1J
POP P,T
HRRI T,TRUE
XCT T
JRST FALSE
SPTB:
IRP Q,,[L,E,LE,G,GE,N]
JUMP!Q TT,(ASCII \Q\)
TERMIN
;PROG2 PROGN PROGN1 EQ RPLACA RPLACD RPLCD3 RPLCD2
SUBTTL PROG2, PROGN, EQ, RPLACA, RPLACD
PROG2: MOVEI D,QPROG2
CAMLE T,XC-2
JRST WNALOSE
HRLI T,-1(T)
ADD T,P
MOVE A,2(T)
MOVEM T,P
POPJ P,
PROGN: AOJG T,FALSE
POP P,A
PROGN1: JUMPE T,CPOPJ
HRLI T,-1(T)
ADD P,T
POPJ P,
EQ: CAMN A,B ;SUBR 2 - POINTER IDENTITY PREDICATE
JRST TRUE
JRST FALSE
RPLACA: SKOTT A,LS
JRST RPLCA0
TLNE TT,PUR+VC
JRST RPLCA1
HRLM B,(A)
POPJ P,
RPLACD: ;SUBR 2 - CLOBBER CDR OF FIRST ARG WITH SECOND
SKOTT A,LS
JRST RPLCD2
TLNE TT,PUR
JRST RPLCD1
RPLCD3: HRRM B,(A)
POPJ P,
RPLCD2: JUMPE A,RPLCD0 ;(RPLACD NIL FOO) IS ALWAYS A LOSS
SKIPE T,VCDR
CAIN T,QLIST ;IF CDR = NIL OR LIST, THEN BOMBOUT
JRST RPLCD0 ;SINCE ARG IS NOT LIST OR NIL
CAIN T,QSYMBOL
TLNE TT,SY
JRST RPLCD3 ;IF NOT CDR = SYMBOL, THEN ANYTHING GOES
JRST RPLCD0
PGTOP EVL,[EVAL, APPLY, STUFF OPEN-CODED BY COMPLR]
;GCRET GCNRT GC MINCEL GCCNT GCCNT1 GCCNT4 LPROG3 GCCNT0 GCCNT1 GCCNT6 GCCNT0
;;@ GCBIB 231 GARBAGE COLLECTOR AND ALLOCATION STUFF
;;; ***** MACLISP ****** GARBAGE COLLECTOR AND ALLOCATION STUFF **
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT GC
SUBTTL GRABBAGE COLLECTORS AND RELATED ITEMS
GCRET: TDZA A,A ;GC WITH NORET=NIL
GCNRT: MOVEI A,TRUTH ;GC WITH NORET=T
HRRI T,UNBIND ;EXPECTS FLAG IN LH OF T
PUSH P,T
JSP T,SPECBIND
0 A,VNORET
JRST AGC
GC: PUSH P,[333333,,FALSE] ;SUBR 0 - USER ENTRY TO GC
JRST AGC ;TO UNDERSTAND THE 3'S, SEE GSTRT7
MINCEL==6*NFF ;MIN NUMBER WORDS TO RECLAIM FOR EACH SPACE
IFG 40-MINCEL, MINCEL==40
IFN KA10+KI10,[
GCCNT: ;FREELIST COUNTING LOOP TO RUN IN AC'S
OFFSET -.
NIL ;SO THAT THE FOLLOWING INS WILL STOP ON NIL
GCCNT1: SKIPE TT,(TT)
GCCNT4: AOJA GCCNT0,.-1 ;OR MAYBE AOBJN
JRST GCP4A
LPROG3==:.-1
GCCNT0:
OFFSET 0
.HKILL GCCNT1 GCCNT4 GCCNT0
] ;END OF IFN KA10+KI10
IFN KL10,[
GCCNT1: SKIPE VGCDAEMON ;FREELIST COUNTING LOOP
JRST GCCNT6
SKIPE TT,(TT)
AOBJN GCCNT0,.-1 ;SHORT ONE FOR JUST SEEING WHETHER >MINCEL
JRST GCP4A
GCCNT6: SKIPE TT,(TT)
AOJA GCCNT0,.-1 ;LONG ONE FOR COUNTING FOR GCDAEMON
JRST GCP4A
GCCNT0==:AR1
] ;END OF IFN KL10
;WHL AGC4 AGC AGC1 AGC1Q GCP4 GCP4A GCP4B
SUBTTL GC - INITIALIZATION
WHL==:USELESS*ITS ;FLAG FOR WHO-LINE STUFF
XCTPRO
AGC4: HRROS NOQUIT ;ENTRY FROM FWCONS, FLCONS, AND THE LIKE
NOPRO
SUBI A,2 ;ENTER WITH JSP A,AGC4
PUSH P,A
XCTPRO
AGC: HRROS NOQUIT ;ENTER HERE WITH PUSHJ P,AGC
NOPRO
SKIPE ALGCF ;CANT SUCCESSFULLY GC WHILE IN ALLOC
JRST ALERR
AGC1:
;MUST HAVE DONE HRROS NOQUIT BEFORE COMING HERE.
;FIRST WE GET CURRENT RUNTIME IN "HOST MACHINE UNITS" IN GCTM1.
;THIS MUST BE DONE IN AND AROUND THE SAVING OF THE AC'S.
IT$ .SUSET [.RRUNT,,GCTM1]
MOVEM NACS+1,GCNASV
10$ SETZ NACS+1,
10$ RUNTIM NACS+1, ;GET RUNTIME FOR THIS JOB
10$ MOVEM NACS+1,GCTM1
MOVEI NACS+1,GCACSAV
BLT NACS+1,GCACSAV+NACS ;BLT AWAY ARG ACS (AND NIL) INTO PROTECTED PLACE
20$ MOVEI 1,.FHSLF
20$ RUNTM ;GET RUNTIME FOR THIS FORK
20$ MOVEM 1,GCTM1
MOVE NACS+1,[NACS+2,,GCNASV+1]
BLT NACS+1,GCNASV+16-<NACS+1> ;SAVE NON-MARKED AC'S EXCEPT SP
MOVE NACS+1,[UUOH,,GCUUSV]
BLT NACS+1,GCUUSV+LUUSV-1 ;SAVE UUOH STUFF, IN CASE STRT IS USED
MOVEI A,TRUTH ;SPECBIND TERPRI TO T, TO PREVENT
JSP T,SPECBIND ; AUTO-TERPRI IN GC MESSAGES
0 A,V%TERPRI
MOVEM SP,GCNASV+17-<NACS+1> ;NOW SAVE SP
SETZM GCFXP
SETZ R,
REPEAT NFF,[
SKIPN FFS+.RPCNT ;FIGURE OUT WHICH SPACE(S) EMPTY
TLO R,400000←-.RPCNT
] ;END OF REPEAT NFF
SKIPN FFY2 ;IF WE RAN OUT OF SYMBOL BLOCKS,
TLO R,400000←<-FFY+FFS> ; THEN CREDIT IT TO SYMBOLS
MOVN D,R ;THIS IS A STANDARD HACK TO KILL ONE BIT
TDZE R,D ;SKIP IF THERE WERE NO BITS
JUMPE R,GCGRAB ;JUMP IF EXACTLY ONE BIT ON
AGC1Q: SETZM GCRMV
AOSE IRMVF ;IF OVERRIDE IS ON, THEN
SKIPE VGCTWA
SETOM GCRMV ;DO REMOVAL ANYHOW.
MOVNI TT,20 ;TOP 40 BITS OF WORD ON
JSP F,GCINBT ;INIT MARK BITS FOR LIST, FIXNUM, ETC.
MOVE T,[SFSSIZ,,OFSSIZ] ;SAVE AWAY OLD SIZES OF SPACES
BLT T,OSASIZ ; (USED FOR ARG TO GC-DAEMON)
MOVE T,VGCDAEMON
IOR T,GCGAGV
IFE WHL, JUMPE T,GCP6
IFN WHL, JUMPE T,GCP5
KAKI MOVSI R,GCCNT
KAKI BLT R,LPROG3
KAKI SKIPN VGCDAEMON
KAKI HRLI GCCNT4,(AOBJN GCCNT0,)
MOVNI R,NFF ;MAY OR MAY NOT HAVE BIGNUMS OR HUNKS
GCP4: SETZ GCCNT0,
SKIPGE FFS+NFF(R)
JRST GCP4B
SKIPN VGCDAEMON
MOVSI GCCNT0,-MINCEL
SKIPE TT,FFS+NFF(R)
AOJA GCCNT0,GCCNT1
GCP4A: TLZ GCCNT0,-1
HRRZ F,GCWORN+NFF(R) ;ACCOUNT FOR LENGTHS OF ITEMS
IMULI GCCNT0,(F)
CAIGE GCCNT0,MINCEL ;IF LESS THEN MINCEL, THEN FREELIST WAS
SETZM FFS+NFF(R) ; "PRACTICALLY EMPTY" AND DESERVES SOME BLAME
GCP4B: HRLM GCCNT0,NFFS+NFF(R)
AOJL R,GCP4
;FALLS THROUGH
;GCP5 GSTRT0 GSTR0A GSTRT1 GSTRT2 GSTRT3 GSTRT5 GSTRT7 GSTRT8 GSTRT6 GCWHL2 GCWHL3 GCWHL9
;FALLS IN
;;; PDLS ARE SAFE
IFN WHL,[
GCP5: MOVE F,GCWHO
SKIPE GCGAGV
JRST GSTRT0
TRNN F,1 ;1-BIT MEANS WE WANT TO SEE
JRST GCP6 ; THE REASON FOR THE GC
JRST GSTR0A ; IN THE WHO-LINE
] ;END OF IFN WHL
IFE WHL,[
SKIPN GCGAGV
JRST GCP6
] ;END OF IFE WHL
GSTRT0: STRT 17,[SIXBIT \↑M;GC DUE TO !\]
GSTR0A: SETZB TT,D ;FIGURE OUT REASON FOR GC
HLRZ T,(P)
CAIN T,111111 ;WAS IT INITIAL STARTUP? (SEE LISP)
MOVEI TT,[SIXBIT \STARTUP!\]
CAIN T,333333 ;WAS IT USER CALLING GC FUNCTION?
MOVEI TT,[SIXBIT \USER!\]
CAIN T,444444 ;WAS IT ARRAYS?
MOVEI TT,[SIXBIT \ARRAY RELOCATION!\]
CAIN T,555555 ;I/O CHANNELS?
MOVEI TT,[SIXBIT \I/O CHANNELS!\]
CAIN T,666666 ;SUSPEND?
MOVEI TT,[SIXBIT \SUSPEND!\]
JUMPN TT,GSTRT8
MOVNI T,NFF ;NONE OF THOSE HYPOTHESES WORK
GSTRT1: SKIPN FFS+NFF(T) ;MAYBE SOME STORAGE SPACE RAN OUT
SKIPA TT,T
ADDI D,1
AOJL T,GSTRT1
JUMPE TT,GSTRT7 ;NO, THAT WASN'T IT
IFN WHL, SKIPN GCGAGV
.ALSO, JRST GSTRT4
MOVNI T,NFF ;YES, IT WAS. PRINT MOBY MESSAGE!
SETZ R,
GSTRT2: SKIPE FFS+NFF(T)
JRST GSTRT5
JUMPE R,GSTRT3
CAIE D,NFF-2
STRT 17,[SIXBIT \, !\]
CAMN T,TT
STRT 17,[SIXBIT \ AND !\]
GSTRT3: SETO R,
STRT 17,@GSTRT9+NFF(T)
GSTRT5: AOJL T,GSTRT2
STRT 17,[SIXBIT \ SPACE!\]
CAIE D,NFF-1
STRT 17,[SIXBIT \S!\]
IFN WHL, GSTRT4: MOVE TT,GSTRT9+NFF(TT)
JRST GSTRT6
GSTRT7: MOVEI TT,[SIXBIT \ ? !\] ;I DON'T KNOW WHY WE'RE HERE!
GSTRT8:
IFN WHL,SKIPE GCGAGV
STRT 17,(TT) ;PRINT REASON
GSTRT6:
IFN WHL,[
TRNN F,1
JRST GCWHL9
MOVE D,(TT)
MOVE R,1(TT)
ROTC D,-22
MOVSI F,(SIXBIT \!\)
MOVE T,[220600,,D]
GCWHL2: ILDB TT,T
CAIE TT,'!
JRST GCWHL2
DPB NIL,T
GCWHL3: IDPB NIL,T
TLNE T,770000
JRST GCWHL3
HRLI D,(SIXBIT \GC:\)
MOVE T,[-6,,GCWHL6]
.SUSET T
GCWHL9:
] ;END OF IFN WHL
;FALLS THROUGH
;GCP6 GCP6Q0 GCP6Q1 GCP6Q2 GCP6Q3 GCP6Q4 GCP6Q5 GCP6Q6 GCP6Q8 GCP6Q9 GCP6R0
;;; PDLS ARE SAFE
SUBTTL GC - MARK THE WORLD
;FALLS IN
GCP6: HRROS MUNGP ;STARTING TO MUNG SYMBOL/SAR MARK BITS
MOVE A,[<-20>←-NUNMRK] ;PRE-PROTECT CERTAIN
ANDM A,BTBLKS ; RANDOM LIST CELLS
MOVNI R,NACS+1 ;PROTECT CONTENTS OF MARKED ACS
GCP6Q0: HRRZ A,GCACSAV+NACS+1(R)
JSP T,GCMARK
AOJL R,GCP6Q0
HRRZ R,C2
ADDI R,1
GCP6Q1: HRRZ A,(R) ;CAUSES MARKING OF CONTENTS
JSP T,GCMARK ; OF ACS AT TIME OF GC, AND OF REG PDL
CAIGE R,(P)
AOJA R,GCP6Q1
MOVEI R,LPROTE-1
GCP6Q2: MOVEI A,BPROTE(R) ;PROTECT PRECIOUS STUFF
JSP T,GCMARK
SOJGE R,GCP6Q2
IFN BIGNUM,[
MOVEI R,LBIGPRO-1
GCP6Q3: MOVEI A,BBIGPRO(R)
JSP T,GCMARK
SOJGE R,GCP6Q3
] ;END OF IFN BIGNUM
MOVSI R,TTS<GC>
IORM R,DEDSAR+TTSAR ;PROTECT DEDSAR
IORM R,DBM+TTSAR ;PROTECT DEAD BLOCK MARKER
HRRZ R,SC2
GCP6Q4: HRRZ A,(R)
JSP T,GCMARK ;MARK SAVED VALUES ON SPEC PDL
CAIGE R,(SP)
AOJA R,GCP6Q4
SKIPN R,INTAR
JRST GCP6Q6
GCP6Q5: MOVE A,INTAR(R)
JSP T,GCMARK
SOJG R,GCP6Q5
GCP6Q6: ;PROTECT INTERRUPT FUNCTIONS
IRP Z,,[0,1,2]X,,[ALARMCLOCK,AUTFN,UDF]
MOVEI R,NUINT!Z
SKIPE A,V!X(R)
JSP T,GCMARK
SOJG R,.-2
TERMIN
SKIPE A,VMERR
JSP T,GCMARK
IFN LHFLAG,[
SKIPN D,LHSGLK ;SKIP IF ANY LH SEGMENTS
JRST GCP6R0 .SEE LHVBAR
GCP6Q8: MOVEI F,(D) ;CREATE AOBJN POINTER INTO SEGMENT
LSH F,SEGLOG
HRLI F,-SEGSIZ
GCP6Q9: HLRZ A,(F) ;MARK FROM ALL ENTRIES IN THAT SEGMENT
JSP T,GCMARK
HRRZ A,(F)
JSP T,GCMARK
AOBJN F,GCP6Q9
LDB D,[SEGBYT,,GCST(D)] ;FOLLOW LINKED LIST OF SEGMENTS
JUMPN D,GCP6Q8
GCP6R0:
] ;END OF IFN LHFLAG
;FALLS THROUGH
;GCP6B1 GCP6B2 GCP6A GCP6F1 GCP6F GCP6F0 GCP6D GCP6D1 GSTRT9 GCWHL6
;;; PDLS ARE SAFE
;FALLS IN
SKIPN GCRMV
JRST GCP6B1
JSP R,GCGEN ;IF DOING TWA REMOVAL, TRY MARKING FROM
GCP8I ;NON-TRIVIAL P-LISTS OF CURRENT OBARRAY
JRST GCP6B2
GCP6B1: MOVE A,VOBARRAY
JSP TT,$GCMKAR ;OTHERWISE, JUST MARK OBARRAY BUCKETS
GCP6B2: MOVEI A,OBARRAY
CAME A,VOBARRAY
JSP TT,$GCMKAR
MOVE R,GCMKL
GCP6A: JUMPE R,GCP6D
HLRZ A,(R)
MOVE D,ASAR(A)
TLNN D,AS<GCP> ;IF ARRAY POINTER HAS "GC ME" BIT SET,
JRST GCP6F
TLNE D,AS<OBA> ;MORE CHECKING ON OBARRAYS
JRST GCP6F0
GCP6F1: JSP TT,GCMKAR ; THEN MARK FROM ARRAY ENTRIES
GCP6F: HRRZ R,(R)
HRRZ R,(R)
JRST GCP6A
GCP6F0: CAMN A,VOBARRAY ; AND IF THIS ISN'T THE CURRENT OBARRAY,
SKIPN GCRMV ; OR IT IS, BUT WE ARENT DOING GCTWA REMOVAL,
JRST GCP6F1
JRST GCP6F
GCP6D: MOVE A,V%TYI
JSP TT,$GCMKAR
MOVE A,V%TYO
JSP TT,$GCMKAR
SKIPN R,PROLIS
GCP6D1: JUMPE R,GCP6H ;PROTECT READ-MACRO
HLRZ A,(R) ; FUNCTIONS (CAN'T JUST GCMARK WHOLE
HLRZ A,(A) ; PROLIS - DON'T WANT TO PROTECT
JSP T,GCMARK ; READTABLE SARS)
HRRZ R,(R)
JRST GCP6D1
GSTRT9: [SIXBIT \LIST!\] .SEE GCWORRY
[SIXBIT \FIXNUM!\] .SEE GCPNT
[SIXBIT \FLONUM!\]
DB$ [SIXBIT \DOUBLE!\]
CX$ [SIXBIT \COMPLEX!\]
DX$ [SIXBIT \DUPLEX!\]
BG$ [SIXBIT \BIGNUM!\]
[SIXBIT \SYMBOL!\]
IRP X,,[2,4,8,16,32,64,128,256,512,1024]
[SIXBIT \HUNK!X!!\]
IFE .IRPCNT-HNKLOG, .ISTOP
TERMIN
[SIXBIT \ARRAY!\]
IFN WHL,[
GCWHL6: .RWHO1,,GCWHO1
.RWHO2,,GCWHO2
.RWHO3,,GCWHO3
.SWHO1,,[.BYTE 8 ? 66 ? 0 ? 366 ? 0 ? .BYTE]
.SWHO2,,D
.SWHO3,,R
] ;IFN WHL
;CGCMKL GCP6H GCP6H1 GCP6H8 GCP6H3 GCP6H4 GCP6H5 GCP6G GCP6H0
;;; PDLS ARE SAFE
SUBTTL GC - CONSIDER THE EFFECTS OF AN ARRAY DISAPPEARING
;;; UPDATE THE GCMKL BY SPLICING OUT ARRAYS TO BE SWEPT.
;;; IF ANY SUCH ARRAYS ARE OPEN FILES, CLOSE THEM.
CGCMKL:
GCP6H: SKIPN F,GCMKL
JRST GCP7
JSP A,GCP6H0
GCP6H1: HLRZ A,(F)
TDNE TT,TTSAR(A)
JRST GCP6G
TDNE T,ASAR(A)
JRST GCP6H7
GCP6H8:
ANDCAM TT,TTSAR(A)
IORM R,TTSAR(A)
MOVEI B,ADEAD
EXCH B,ASAR(A)
TLNN B,AS<RDT>
JRST GCP6G
MOVEI AR1,PROLIS ;JUST KILLED A READTABLE
GCP6H3: HRRZ AR2A,(AR1) ; - CLEAN UP PROLIS
GCP6H4: JUMPE AR2A,GCP6G
HLRZ C,(AR2A)
HRRZ C,(C)
HLRZ C,(C)
CAIE C,(A)
JRST GCP6H5
HRRZ AR2A,(AR2A)
HRRM AR2A,(AR1)
JRST GCP6H4
GCP6H5: MOVEI AR1,(AR2A)
JRST GCP6H3
GCP6G: HRRZ F,(F)
HRRZ F,(F)
JUMPN F,GCP6H1
JRST GCP7
GCP6H0: MOVSI T,AS<JOB+FIL> ;SET UP SOME ACS FOR THE GCMKL-LOOK LOOP
MOVE R,[TTDEAD]
MOVSI TT,TTS<CN+GC>
JRST (A)
;GCP6H7 GCP6H2 GCP6H9 GCP6J1 GCP6J3 GCP6J9
;;; PDLS ARE SAFE
;;; CLEAN UP AND CLOSE A FILE WHEN GARBAGE COLLECTED
GCP6H7: MOVE B,TTSAR(A) ;ABOUT TO GC A FILE ARRAY
TLNE B,TTS<CL> ;IGNORE IF ALREADY CLOSED
JRST GCP6H8
PUSH P,F
IFN JOBQIO,[
HLL B,ASAR(A)
TLNE B,AS<JOB>
JRST GCP6J1
] ;END OF IFN JOBQIO
PUSHJ P,ICLOSE ;OTHERWISE CLOSE THE FILE
MOVEI R,[SIXBIT \↑M;FILE CLOSED: !\]
GCP6H2: SKIPN GCGAGV
JRST GCP6H9
STRT 17,(R)
HLRZ A,@(P)
HRRZ AR1,VMSGFILES
TLO AR1,200000
HRROI R,$TYO
PUSHJ P,PRINTA
GCP6H9: POP P,F
JSP A,GCP6H0 ;RE-INIT MAGIC CONSTANTS IN ACS
HLRZ A,(F)
JRST GCP6H8
IFN JOBQIO,[
;;; CLEAN UP AND CLOSE AN INFERIOR PROCEDURE WHEN GARBAGE COLLECTED
GCP6J1:
IFN ITS,[
MOVEI R,[SIXBIT \↑M;FOREIGN JOB FLUSHED: !\]
SKIPN T,J.INTB(B)
JRST GCP6J3
MOVEI R,[SIXBIT \↑M;INFERIOR JOB FLUSHED: !\]
.CALL GCP6J9 ;IF INFERIOR JOB, OPEN IT ON
.VALUE ; THE TEMPORARY I/O CHANNEL
.UCLOSE TMPC, ; AND KILL IT
JFFO T,.+1
MOVNS TT
SETZM JOBTB+21(TT) ;CLEAR ENTRY IN JOB TABLE
] ;END OF IFN ITS
GCP6J3: MOVSI T,TTS<CL> ;MARK THE JOB OBJECT AS BEING CLOSED
ANDCAM T,TTSAR(A)
JRST GCP6H2
IFN ITS,[
GCP6J9: SETZ
SIXBIT \OPEN\ ;OPEN FILE (INFERIOR PROCEDURE)
1000,,TMPC ;CHANNEL NUMBER
,,F.DEV(B) ;DEVICE NAME (USR)
,,F.FN1(B) ;FILE NAME 1 (UNAME)
400000,,F.FN2(B) ;FILE NAME 2 (JNAME)
] ;END OF IFN ITS
] ;END OF IFN JOBQIO
;GCP7
;;; PDLS ARE SAFE
SUBTTL GC - TWA REMOVAL
GCP7: HRRZ A,GCMKL
JSP T,GCMARK
HRRZ A,PROLIS
JSP T,GCMARK
SKIPN GCRMV
JRST GCSWP
JSP R,GCGEN ;IF DOING TWA REMOVAL, THEN WIPE OUT
GCP8G ; T.W.A.'S AND THEN MARK BUCKETS
MOVE A,VOBARRAY
JSP TT,$GCMKAR
;FALLS THROUGH
;GCSWP GCSW1 GCSW2 GCSW2A GCSW5 GCSW7
;;; PDLS ARE UNSAFE
SUBTTL GC - SWEEP THE WORLD
;FALLS IN
GCSWP: .SEE KLINIT ;WHICH CLOBBERS NEXT INSTRUCTION
MOVEM FXP,GCFXP ;WE ARE ABOUT TO CLOBBER THE PDL POINTERS
MOVNI SP,NFF ;NUMBER OF SPACES TO SWEEP
MOVEM SP,GC99
;MAJOR SWEEP LOOP OVER ALL SPACES
GCSW1:
IFN KA10+KI10,[
MOVE FXP,GCSWTB+NFF(SP) ;PUT INNER SWEEP LOOP IN AC'S
HLLZ FLP,FXP ; AND INITIALIZE COUNT
BLT FLP,(FXP)
SETZ FXP, ;FREELIST INITIALLY NIL
] ;END OF IFN KA10+KI10
KL SETZB A,FXP ;FXP HAS FREELIST, A HAS COUNT
SKIPN FLP,FSSGLK+NFF(SP)
JRST GCSW7
;MINOR SWEEP LOOP OVER ALL SEGMENTS IN A SPACE
GCSW2: MOVEM FLP,GC98
JRST @GCSW2A+NFF(SP) ;DISPATCH ON TYPE TO SEPARATE ROUTINES
GCSW2A: GCSWS ;LIST
GCSWS ;FIXNUM
GCSWS ;FLONUM
DB$ GCSWD ;DOUBLE
CX$ GCSWC ;COMPLEX
DX$ GCSWZ ;DUPLEX
BG$ GCSWS ;BIGNUM
GCSWY ;SYMBOL
IFN HNKLOG, GCSWH1
REPEAT HNKLOG,[
IFL .RPCNT-4, GCSWH1 ;HUNKS OF LESS THAN 40 WORDS
.ELSE GCSWH2 ;HUNKS OF 40 WORDS OR MORE
] ;END OF REPEAT HNKLOG
GCSWA ;SARS
IFN .-GCSW2A-NFF, WARN [WRONG LENGTH TABLE]
GCSW5: MOVE SP,GC99
MOVE FLP,GC98
LDB FLP,[SEGBYT,,GCST(FLP)]
JUMPN FLP,GCSW2
GCSW7:
KAKI HRRZ A,@GCSW7A+NFF(SP)
HRRM FXP,FFS+NFF(SP) ;SAVE FREELIST - DON'T DISTURB SIGN BIT
HRRZ B,GCWORN+NFF(SP)
IMULI A,(B) ;ACCOUNT FOR SIZE OF OBJECTS IN THIS SPACE
HRRM A,NFFS+NFF(SP) ;SAVE COUNT OF WORDS COLLECTED
AOSGE SP,GC99
JRST GCSW1
HRRZS MUNGP ;WE HAVE UNDONE MUNGING OF BITS
MOVSI F,TTS<CN+GC>
ANDCAM F,DEDSAR ;MUST CLEAR BITS IN DEDSAR
JSP NACS+1,GCACRS ;RESTORE ACCUMULATORS
JRST GCPNT ;NEXT PRINT STATISTICS
;GCSWTB GCSW7A
;;; PDLS ARE UNSAFE
IFN KA10+KI10,[
;TABLE OF SWEEPERS FOR RUNNING IN ACS AND THE LAST LOCATIONS TO LOAD THEM INTO
GCSWTB: GCFSSWP,,LPROG1 ;LIST
GCFSSWP,,LPROG1 ;FIXNUM
GCFSSWP,,LPROG1 ;FLONUM
DB$ GCHSW1,,LPROGH ;DOUBLE
CX$ GCHSW1,,LPROGH ;COMPLEX
DX$ GCHSW1,,LPROGH ;DUPLEX
BG$ GCFSSWP,,LPROG1 ;BIGNUM
GSYMSWP,,LPROG6 ;SYMBOL
IFN HNKLOG, GCHSW1,,LPROGH
REPEAT HNKLOG,[
IFL .RPCNT-4, GCHSW1,,LPROGH ;HUNKS OF LESS THAN 40 WORDS
.ELSE GCHSW2,,LPROGK ;HUNKS OF 40 WORDS OR MORE
] ;END OF REPEAT HNKLOG
GSARSWP,,LPROG4 ;SARS
IFN .-GCSWTB-NFF, WARN [WRONG LENGTH TABLE]
;TABLE OF AC FOR EACH SWEEPER WHICH HOLDS COUNT OF OBJECTS SWEPT
GCSW7A: GFSCNT ;LIST
GFSCNT ;FIXNUM
GFSCNT ;FLONUM
DB$ GHCNT1 ;DOUBLE
CX$ GHCNT1 ;COMPLEX
DX$ GHCNT1 ;DUPLEX
BG$ GFSCNT ;BIGNUM
GYCNT ;SYMBOL
IFN HNKLOG, GHCNT1
REPEAT HNKLOG,[
IFL .RPCNT-4, GHCNT1 ;HUNK OF LESS THAN 40 WORDS
.ELSE GHCNT2 ;HUNKS OF 40 WORDS OR MORE
] ;END OF REPEAT HNKLOG
GSCNT ;SARS
IFN .-GCSW7A-NFF, WARN [WRONG LENGTH TABLE]
] ;END OF IFN KA10+KI10
;GCSWS GCFSSWP GFSP1 GFSP2 GFSP4 GFSP5 GCSWY GSYMSWP GYSP1 GYSP2 GYCNT GYSP3 GYSP5 GYSP5A GYSP5B
;;; PDLS ARE UNSAFE
GCSWS: MOVE P,GCST(FLP) ;GET SHIFTED ADDRESS OF BIT BLOCK
LSH P,SEGLOG-5 ;SHIFT BACK TO FORM WORD ADDRESS
HRLI P,-BTBSIZ ;MAKE AOBJN POINTER OVER WORDS OF BITS
LSH FLP,SEGLOG
HRLI FLP,-40 ;40 CELLS PER WORD OF BITS
KAKI JRST GFSP1
;FXP HAS RUNNING FREELIST
;FLP HAS AOBJN POINTER OVER CELLS
;P HAS AOBJN POINTER OVER WORDS OF BITS
GCFSSWP: ;SWEEPER FOR LIST, FIXNUM, FLONUM, BIGNUM
KAKI OFFSET -. ;RELOCATED TO ACS FOR KA AND KI
GFSP1: SKIPN SP,(P) ;GET A WORD OF MARK BITS
JRST GFSP5 ;IF ALL 40 WORDS MARKED, THIS SAVES TIME
GFSP2: JUMPGE SP,GFSP4 ;JUMP IF SINGLE WORD MARKED
HRRZM FXP,(FLP) ;ELSE CHAIN INTO FREE LIST
HRRZI FXP,(FLP)
KAKI GFSCNT: AOJ .,0 ;RH COUNTS RECLAIMED CELLS
KL ADDI A,1
GFSP4: ROT SP,1 ;ROTATE NEXT MARK BIT UP
AOBJN FLP,GFSP2 ;COUNT OFF 40 WORDS
TLOA FLP,-40 ;RESET 40-WORD COUNT IN AOBJN POINTER
GFSP5: ADDI FLP,40 ;SKIP OVER 40 WORDS IN SWEEP
AOBJN P,GFSP1 ;<BTBSIZ> BLOCKS OF 40 WORDS
JRST GCSW5
KAKI LPROG1==:.-1
KAKI OFFSET 0
KAKI .HKILL GFSP1 GFSP2 GFSCNT GFSP4 GFSP5
GCSWY: LSH FLP,SEGLOG
HRLI FLP,-SEGSIZ
KL MOVEI GYSP7,(300,,0) ;3.8=PURE, 3.7=COMPILED CODE REFS
KAKI JRST GYSP1
KL GYSP7==:0
GSYMSWP: ;SWEEPER FOR SYMBOL SPACE
KAKI OFFSET -.
KAKI GYSP7: (300,,0) ;3.8=PURE, 3.7=COMPILED CODE REFS (NOTE: TSNE WITH ITSELF ALWAYS SKIPS)
GYSP1: HLRZ SP,(FLP)
TRZN SP,1 ;IF MARKED,
TSNE GYSP7,(SP) ; OR IF PURE OR COMPILED CODE NEEDS IT,
JRST GYSP3 ; THEN DO NOT SWEEP UP
JUMPN SP,GYSP5 ;IF NON-NIL LEFT HALF, RECLAIM THE SYMBOL BLOCK
GYSP2: HRRZM FXP,(FLP) ;CHAIN ONTO FREELIST
HRRZI FXP,(FLP)
GYCNT:
KAKI AOJ .,0
KL ADDI A,1 ;INCREMENT OBJECT COUNT
GYSP3: HRLM SP,(FLP)
AOBJN FLP,GYSP1
JRST GCSW5
KAKI LPROG6==:.-1
KAKI OFFSET 0
KAKI .HKILL GYSP1 GYSP2 GYSP3 GYSP7 GYCNT
;;; PART OF SYMBOL SWEEPER - RESTORES A SYMBOL BLOCK TO FFY2.
;;; ALSO ATTEMPTS TO RETURN THE VALUE CELL IF IT HAS ONE.
GYSP5: EXCH SP,FFY2 ;RETURN SYMBOL BLOCK TO FREELIST
EXCH SP,@FFY2
TLZ SP,-1 ;MAYBE TRY TO RETURN A VALUE CELL
CAIE SP,SUNBOUND
JRST GYSP5A
SETZ SP,
JRST GYSP2
GYSP5A: CAIL SP,BXVCSG+NXVCSG*SEGSIZ
JRST GYSP5B ;CAN ONLY RETURN CELLS IN VC SPACE
EXCH SP,FFVC
MOVEM SP,@FFVC
GYSP5B: SETZ SP,
JRST GYSP2
;GCSWD GCSWC GCSWZ GCSWH1 GCHSW1 GH1SP1 GH1SP2 GHCNT1 GH1SP4 GH1SP5 GH1SP6 GH1SP4
;;; PDLS ARE UNSAFE
IFN HNKLOG+DBFLAG+CXFLAG,[
GCSWD:
GCSWC:
GCSWZ:
GCSWH1: HRRZ P,GCWORN+NFF(SP) ;GET SIZE OF OBJECTS
KAKI HRRI GH1SP4,(P)
KL MOVEI B,(P)
SUBI P,1
KAKI HRRI GH1SP5,(P)
KL MOVEI C,(P)
HRRZ P,GCWORN+NFF(SP)
MOVNI SP,40
IDIVM SP,P
KAKI HRRI GH1SP6,(P) ;BITS PER BIT BLOCK WORD
KL MOVEI AR1,(P)
MOVE P,GCST(FLP) ;GET SHIFTED ADDRESS OF BIT BLOCK
LSH P,SEGLOG-5 ;SHIFT BACK TO FORM WORD ADDRESS
HRLI P,-BTBSIZ ;MAKE AOBJN POINTER OVER WORDS OF BITS
LSH FLP,SEGLOG ;MAKE AOBJN POINTER OVER CELLS
KAKI HRLI FLP,(GH1SP6)
KL HRLI FLP,(AR1)
KAKI JRST GH1SP1
;FXP HAS RUNNING FREELIST
;FLP HAS AOBJN POINTER OVER CELLS
;P HAS AOBJN POINTER OVER WORDS OF BITS
GCHSW1:
KAKI OFFSET -.
GH1SP1: MOVE SP,(P)
GH1SP2: JUMPGE SP,GH1SP4
HRRZM FXP,(FLP)
HRRZI FXP,(FLP)
IFN KA10+KI10,[
GHCNT1: AOJ .,0
GH1SP4: ROT SP,1←HNKLOG
GH1SP5: ADDI FLP,<1←HNKLOG>-1
AOBJN FLP,GH1SP2
GH1SP6: HRLI FLP,<-40>←-HNKLOG
] ;END OF IFN KA10+KI10
IFN KL10,[
ADDI A,1
GH1SP4: ROT SP,(B)
ADDI FLP,(C)
AOBJN FLP,GH1SP2
HRLI FLP,(AR1)
] ;END OF IFN KL10
AOBJN P,GH1SP1
JRST GCSW5
KAKI LPROGH==:.-1
KAKI OFFSET 0
KAKI .HKILL GH1SP1 GH1SP2 GHCNT1 GH1SP4 GH1SP5 GH1SP6
] ;END OF IFN HNKLOG+DBFLAG+CXFLAG
;GCSWH2 GCHSW2 GH2SP1 GHCNT2 GH2SP5 GH2SP7 GH2SP5 GCSWA GSARSWP GSSP0 GSSP1 GSSP2
;;; PDLS ARE UNSAFE
IFG HNKLOG-4,[
GCSWH2: HRRZ P,GCWORN+NFF(SP) ;GET SIZE OF OBJECTS
KAKI HRRI GH2SP5,(P)
KL MOVEI B,(P)
SUBI P,1
LSH P,-5
KAKI HRRI GH2SP7,(P) ;BITS PER BIT BLOCK WORD
KL MOVEI AR2A,(P)
HRRZ P,GCWORN+NFF(SP)
LSH P,-5
MOVNI SP,BTBSIZ
IDIVM SP,P
HRLI P,(P) ;MAKE AOBJN POINTER OVER WORDS OF BITS
MOVE SP,GCST(FLP)
LSH SP,SEGLOG-5
HRRI P,(SP)
LSH FLP,SEGLOG ;MAKE POINTER OVER CELLS
KAKI JRST GH2SP1
;FXP HAS RUNNING FREELIST
;FLP HAS AOBJN POINTER OVER CELLS
;P HAS AOBJN POINTER OVER WORDS OF BITS
GCHSW2:
KAKI OFFSET -.
GH2SP1: SKIPL (P) ;ONLY THE SIGN BIT OF A MARK WORD IS USED
JRST GH2SP5
HRRZM FXP,(FLP)
HRRZI FXP,(FLP)
IFN KA10+KI10,[
GHCNT2: AOJ .,0
GH2SP5: ADDI FLP,1←HNKLOG
GH2SP7: ADDI P,<<1←HNKLOG>-1>←-5
] ;END OF IFN KA10+KI10
IFN KL10,[
ADDI A,1
GH2SP5: ADDI FLP,(B)
ADDI P,(AR2A)
] ;END OF IFN KL10
AOBJN P,GH2SP1
JRST GCSW5
KAKI LPROGK==:.-1
KAKI OFFSET 0
KAKI .HKILL GH2SP1 GH2SP2 GHCNT2 GH2SP5 GH2SP7
] ;END OF IFG HNKLOG-4
GCSWA: LSH FLP,SEGLOG
HRLI FLP,-SEGSIZ/2
KL MOVSI B,(TTS<CN+GC>,,)
KL MOVSI C,(TTS<GC>,,)
JRST GSSP1
GSARSWP: ;SPECIAL SWEEPER FOR SARS
KAKI OFFSET -.
GSSP0: ADDI FLP,1
GSSP1:
KAKI TDNN GSSP7,TTSAR(FLP) ;TEST IF SAR MARKED (OR OTHERWISE NEEDED)
KL TDNN B,TTSAR(FLP)
KAKI AOJA GSCNT,GSSP2 ;NO, COUNT IT AS SWEPT
KL AOJA A,GSSP2
KAKI ANDCAM GSSP8,TTSAR(FLP) ;YES, TURN OFF MARK BIT
KL ANDCAM C,TTSAR(FLP)
AOBJN FLP,GSSP0 ; AND TRY NEXT ONE
JRST GCSW5
GSSP2: HRRZM FXP,ASAR(FLP) ;CHAIN INTO FREE LIST
HRRZI FXP,ASAR(FLP)
AOBJN FLP,GSSP0
JRST GCSW5
KAKI GSSP7: TTS<CN+GC>,,
KAKI GSSP8: TTS<GC>,,
KAKI GSCNT: 0
KAKI LPROG4==:.-1
KAKI OFFSET 0
KAKI .HKILL GSSP0 GSSP1 GSSP2 GSSP7 GSSP8 GSCNT
;GCPNT GCPNT1 GCPNT2 GCPNT6
;;; PDLS ARE SAFE
SUBTTL GC - MAKE SURE ENOUGH WAS RECLAIMED
GCPNT: SKIPN GCGAGV
JRST GCE0
SETZM GC99 ;GC99 COUNTS ENTRIES PRINTED
MOVNI F,NFF
GCPNT1: HRRZ T,NFFS+NFF(F)
SKIPN TT,SFSSIZ+NFF(F)
JRST GCPNT6
SOSLE GC99
JRST GCPNT2
STRT 17,[SIXBIT \↑M; !\] ;TERPRI-; EVERY THIRD ONE
MOVEI D,3
MOVEM D,GC99
GCPNT2: PUSHJ P,STGPNT
STRT 17,@GSTRT9+NFF(F)
CAME F,XC-1 ;COMMA AFTER EACH BUT LAST
STRT 17,[SIXBIT \, !\]
GCPNT6: AOJL F,GCPNT1
STRT 17,[SIXBIT \ WORDS FREE!\]
;FALLS THROUGH
;GCE0 GCE0C0 GCE0C1 GCE0C5 GCE0C2 GCE0C3 GCE0C9 GCE0C6 GCE0K3 GCE0C7 GCE0C4 GCE0K2 GCE0K1
;;; PDLS ARE SAFE
SUBTTL GC - CLEANUP AND TERMINATION
;FALLS IN
GCE0: MOVNI F,NFF
GCE0C0: MOVE AR2A,MFFS+NFF(F)
TLNN AR2A,-1
JRST GCE0C1
HRRZ AR1,SFSSIZ+NFF(F)
FSC AR1,233 ;FIXNUM TO FLONUM CONVERSION
FMPR AR1,AR2A
MULI AR1,400 ;FLONUM TO FIXNUM CONVERSION
ASH AR2A,-243(AR1)
GCE0C1: SKIPGE FFS+NFF(F)
JRST GCE0C5
CAIGE AR2A,MINCEL
MOVEI AR2A,MINCEL ;MUST SATISFY ABSOLUTE MIN OF<MINCEL> CELLS
GCE0C5: MOVEM AR2A,ZFFS+NFF(F)
HRRZ TT,NFFS+NFF(F)
CAIGE TT,(AR2A) ;ALSO MUST SATISFY USER'S MIN
PUSHJ P,GCWORRY ;IF NOT, MUST WORRY ABOUT IT
GCE0C2: AOJL F,GCE0C0
MOVEI AR2A,1
SKIPN FFY2
PUSHJ P,GRABWORRY ;REMEMBER, F IS ZERO HERE
SKIPN FFY2
JRST GCLUZ
MOVNI F,NFF ;IF WE RECLAIMED LESS THAN ABSOLUTE
GCE0C3: HRRZ TT,NFFS+NFF(F) ; MINIMUM FOR ANY SPACE,
SKIPGE FFS+NFF(F)
JRST GCE0C9
CAIGE TT,MINCEL ; WE ARE OFFICIALLY DEAD
JRST GCLUZ
GCE0C9: AOJL F,GCE0C3
SKIPE PANICP
JRST GCE0C7
MOVNI F,NFF ;NOW SEE IF WE EXCEEDED MAXIMUM
GCE0C6: MOVE TT,SFSSIZ+NFF(F)
CAMG TT,XFFS+NFF(F)
JRST GCE0K3
HRLZ D,GCMES+NFF(F)
HRRI D,1004 ;GC-OVERFLOW
PUSHJ P,UINT ;NOQUIT SET, SO INTERRUPT GETS STACKED
GCE0K3: AOJL F,GCE0C6
GCE0C7: MOVNI F,NFF
GCE0C4: MOVE TT,SFSSIZ+NFF(F)
CAMG TT,XFFS+NFF(F) ;IF A SPACE LOST TO GC-OVERFLOW,
JRST GCE0K2 ; DON'T MAKE IT LOSE FOR GC-LOSSAGE TOO
MOVEM TT,XFFS+NFF(F) ;JUST QUIETLY UPDATE ITS GCMAX
JRST GCE0K1
GCE0K2: HRRZ T,NFFS+NFF(F)
CAMGE T,ZFFS+NFF(F)
JRST GCLUZ
GCE0K1: AOJL F,GCE0C4
IFE D10,[
HRRZ TT,NOQUIT
IOR TT,INHIBIT
IOR TT,VNORET
SKIPN TT
PUSHJ P,RETSP
] ;END OF IFE D10
SKIPE GCGAGV
STRT 17,STRTCR
;FALLS THROUGH
;GCE0E
;;; PDLS ARE SAFE
;FALLS IN
SKIPN VGCDAEMON
JRST GCEND
MOVEI C,NIL ;CONS UP ARG FOR GCDAEMON
MOVEI D,NFF-1 ;WE CHECKED LENGTH OF FREELISTS SO
SETZ C, ; WE KNOW CONSES WON'T RE-INVOKE GC
GCE0E: MOVE TT,SFSSIZ(D) ;SIZE OF SPACE AFTER GC
PUSHJ P,CONS1FX
MOVE TT,OFSSIZ(D) ;SIZE OF SPACE BEFORE GC
PUSHJ P,CONSFX
HRRZ TT,NFFS(D) ;LENGTH OF FREELIST AFTER GC
CAIN D,FFX-FFS ;ALLOW FOR THE SPACE USED
SUBI TT,4*NFF ; TO CONS UP THE GC-DAEMON ARG
CAIN D,FFS-FFS
SUBI TT,6*NFF
PUSHJ P,CONSFX
HLRZ TT,NFFS(D) ;LENGTH OF FREELIST BEFORE GC
PUSHJ P,CONSFX
HRRZ A,GCMES(D) ;NAME OF SPACE
PUSHJ P,CONS
MOVE B,C
PUSHJ P,CONS
MOVE C,A
SOJGE D,GCE0E
JSR GCRSR .SEE GCRSR0
HRLI A,1003 ;GC-DAEMON
PUSH P,A ;FOR INTERRUPT PROTECTION ONLY
PUSH FXP,D
MOVS D,A
PUSHJ P,UINT
POP FXP,D
JRST S1PAJ
;GCEND GCRSR0
;;; GC MUST EITHER JRST TO GCEND, OR JSR TO GCRSR BEFORE EXITING.
;;; THIS ASSURES THAT GCTIM WILL PROPERLY REFLECT TIME SPENT IN GC.
;;; THE VALUE IN GCTIM IS IN "HOST MACHINE UNITS".
;;; THESE ARE CONVERTED BEFORE BEING RETURNED TO THE USER.
.SEE SGCTIM
GCEND:
IFN D20,[
MOVEI 1,.FHSLF
RUNTM ;UPDATE GCTIM FOR D20
IFN WHL, MOVEM 1,GC98
SUB 1,GCTM1
ADDM 1,GCTIM
] ;END OF IFN D20
MOVE P,GCNASV+14-<NACS+1>
MOVE SP,GCNASV+17-<NACS+1>
PUSHJ P,UNBIND
JSP NACS+1,GCACR
SETZM GCFXP
IFE D20,[
IT$ .SUSET [.RRUNT,,NACS+1]
10$ SETZ NACS+1,
10$ RUNTIM NACS+1,
IFN WHL, MOVEM NACS+1,GC98
SUB NACS+1,GCTM1
ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME)
] ;END OF IFE D20
IFN WHL,[
SKIPE NACS+1,GCWHO
PUSHJ P,GCWHR
] ;END OF IFN WHL
MOVE NACS+1,GCNASV
HRRZS NOQUIT
JRST CHECKI
;GCRSR: 0
GCRSR0: HRLM C,NOQUIT ;RESTORE ACS, AND CHECK FOR ANY STACKED INTERRUPTS
IFN D20,[
MOVEI 1,.FHSLF
RUNTM ;UPDATE GCTIM FOR D20
IFN WHL, MOVEM 1,GC98
SUB 1,GCTM1
ADDM 1,GCTIM
] ;END OF IFN D20
MOVE P,GCNASV+14-<NACS+1>
MOVE SP,GCNASV+17-<NACS+1>
PUSHJ P,UNBIND
JSP NACS+1,GCACR ;RESTORE AC'S
SETZM GCFXP
IT$ .SUSET [.RRUNT,,NACS+1]
10$ SETZ NACS+1,
10$ RUNTIM NACS+1,
IFN WHL*<ITS+D10>, MOVEM NACS+1,GC98
SUB NACS+1,GCTM1
ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME)
IFN WHL,[
SKIPE NACS+1,GCWHO
PUSHJ P,GCWHR
] ;END OF IFN WHL
MOVE NACS+1,GCNASV
PUSH P,A
HLRZ A,NOQUIT
PUSH P,GCRSR
HRRZS NOQUIT
JRST CHECKI
;GCINBT GCINB0 GCWHR GCWHR8 GCWHR2 GCWHR9
;;; ROUTINE TO INIT MARK BITS FOR LIST, FIXNUM, FLONUM, HUNK,
;;; AND BIGNUM SPACES. INIT BITS IN TT, RETURN ADDRESS IN F.
GCINBT: MOVEM TT,BBITSG
MOVE AR2A,[BBITSG,,BBITSG+1]
BLT AR2A,@MAINBITBLT ;BLT OUT MAIN BIT AREA
MOVE A,BTSGLK ;INITIALIZE ALL BIT BLOCKS
GCINB0: JUMPE A,(F)
MOVEI AR2A,(A)
LSH AR2A,SEGLOG ;GET ADDRESS OF SEGMENT
HRLI AR2A,(AR2A)
MOVEM TT,(AR2A)
AOJ AR2A,
MOVE T,GCST(A) ;GET END ADDRESS FOR BLT
LSH T,SEGLOG-5
TLZ T,-1
CAIE T,(AR2A)
BLT AR2A,-1(T) ;***BLT!***
LDB A,[SEGBYT,,GCST(A)]
JRST GCINB0
IFN WHL,[
GCWHR: TRNN NACS+1,2 ;SKIP IF GC STATISTICS DESIRED
JRST GCWHR2
MOVE NACS+2,GCTIM
IDIVI NACS+2,25000./4 ;GC TIME IN FORTIETHS OF A SECOND
MOVEM NACS+2,GCWHO2
MOVE NACS+2,GCTIM ;GC TIME
IMULI NACS+2,100. ; TIMES 100.
IDIV NACS+2,GC98 ; DIVIDED BY TOTAL RUNTIME
HRLM NACS+2,GCWHO2 ; EQUALS GC TIME PERCENTAGE
TRNE NACS+1,1
JRST GCWHR2
.SUSET [.SWHO2,,GCWHO2] ;JUST SET .WHO2 IF WHO VARS NOT PREVIOUSLY SAVED
GCWHR8: MOVE NACS+2,GCNASV+1 ;RESTORE ACS
MOVE NACS+3,GCNASV+2
POPJ P,
GCWHR2: MOVE NACS+2,[-3,,GCWHR9] ;RESTORE WHO VARS, POSSIBLY WITH
.SUSET NACS+2 ; GC STATISTICS CLOBBERED INTO GCWHO2
JRST GCWHR8
GCWHR9: .SWHO1,,GCWHO1
.SWHO2,,GCWHO2
.SWHO3,,GCWHO3
] ;IFN WHL
;GCACRS GCACR $GCMKAR GCMKAR GCMKA1 GCGEN GCP8A GCP8A1
SUBTTL MISCELLANEOUS GC UTILITY ROUTINES
GCACRS: MOVE SP,GCNASV+17-<NACS+1> ;RESTORE SP ALSO
GCACR: SKIPN GCFXP
MOVEM FXP,GCFXP
MOVE NIL,[GCACSAV+1,,1] ;RESTORE ALL ACS EXCEPT NACS+1
BLT NIL,NACS
MOVE NIL,[GCNASV+1,,NACS+2]
BLT NIL,FXP
MOVE NIL,GCACSAV
SETZM GCFXP .SEE CHNINT ;ETC.
JRST (NACS+1)
$GCMKAR: MOVE D,ASAR(A)
GCMKAR: MOVE F,TTSAR(A)
SKIPL D,-1(D) ;MARK FROM ARRAY ENTRIES.
JRST (TT)
GCMKA1: HLRZ A,(D)
JSP T,GCMARK
HRRZ A,(D)
JSP T,GCMARK
AOBJN D,GCMKA1
JUMPE F,(TT)
TLNE F,TTS<TY>
TLNE F,TTS<IO>
JRST (TT)
MOVEI D,FB.BUF(F) ;FOR TTY INPUT FILE ARRAYS,
HRLI D,-NASCII/2 ; MUST MARK INTERRUPT FUNCTIONS
SETZ F,
JRST GCMKA1
;;; GCGEN GENERATES NON-NULL BUCKETS OF THE CURRENT OBARRAY
;;; AND APPLIES A GIVEN FUNCTION TO THEM. IT IS CALLED AS
;;; JSP R,GCGEN
;;; FOO
;;; GCGEN WILL EFFECTIVELY DO A JRST FOO MANY TIMES,
;;; PASSING SOME NON-NULL OBARRAY BUCKET THROUGH ACCUMULATOR D.
;;; FOO IS EXPECTED TO RETURN BY DOING A JRST GCP8A.
;;; WHEN DONE, GCGEN RETURNS, SKIPPING OVER THE ADDRESS FOO.
GCGEN: MOVE F,@VOBARRAY .SEE ASAR
MOVE F,-1(F)
SUB F,R70+1
TLZ R,400000
GCP8A: TLCE R,400000
JRST GCP8A1
AOBJP F,1(R) ;EXIT
HLRZ D,(F)
JUMPN D,@(R)
JRST GCP8A
GCP8A1: HRRZ D,(F)
JUMPN D,@(R)
JRST GCP8A
;GCMARK GCMRK0 GCMRK3 GCMRK6 GCMRK7 GCMRK4 GCMRK5 GCMKND GCMRK8 GCMRK1 GCMRK2 GCMK2A GCMK2B GCHNLN
;;; MARK AN S-EXPRESSION GIVEN IN A. TRACES IT COMPLETELY,
;;; MARKING ALL SUBITEMS BY SETTING A MARK BIT TO **ZERO**
;;; FOR LIST, FIXNUM, FLONUM, AND BIGNUM SPACES, AND TO
;;; **ONE** FOR SYMBOLS AND SARS. (THIS SPEEDS UP SWEEPING.)
;;; NEVER MARKS VALUE CELLS!!!! (THEY ARE NEVER SWEPT.)
;;; CALLED BY JSP T,GCMARK WITH OBJECT IN A. USES A,B,C,AR1,AR2A.
GCMARK: JUMPE A,(T) ;NEEDN'T MARK NIL
MOVEI AR2A,(P) ;REMEMBER WHERE P IS
GCMRK0: JRST GCMRK1 .SEE KLINIT
GCMRK3: TLNN A,GCBSYM ;MAYBE WE FOUND A SYMBOL
JRST GCMRK4 ;NOPE
HLRZ AR1,(C) ;YUP
TROE AR1,1
JRST GCMKND
HRLM AR1,(C)
PUSH P,(C) ;PUSH PROPERTY LIST
PUSH P,(AR1) ;PUSH PNAME LIST
SKIPE ETVCFLSP ;A HAC TO SAVE TIME IF THERE NEVER HAVE BEEN
JRST GCMRK6 ; VALUE CELLS TAKEN FROM LIST SPACE
HRRZ A,@-1(AR1)
JRST GCMRK1 ;GO MARK VALUE OF SYMBOL
GCMRK6: HRRZ A,-1(AR1)
CAIGE A,EVCSG
CAIGE A,BVCSG
JRST GCMRK7
HRRZ A,(A)
CAIE A,QUNBOUND
JRST GCMRK1
JRST GCMRK8
GCMRK7: LSH A,-SEGLOG
SKIPL A,GCST(A) ;SKIP IF VALUE CELL NOT A LIST CELL??
JRST GCMKND ;SUNBOUND, FOR EXAMPLE????
HRRZ A,-1(AR1) ;POINTING TO A VC IN LIST SPACE
JRST GCMRK1
GCMRK4: TLNN A,GCBVC ;MAYBE WE FOUND A VALUE CELL
JRST GCMRK5 ;NOPE
HRRZ A,(C) ;YUP - MARK ITS CDR (THE VALUE)
JRST GCMRK1
GCMRK5: MOVSI AR1,TTS<GC> ;MUST BE AN ARRAY
IORM AR1,TTSAR(C) ;SET ARRAY MARK BIT TO 1
GCMKND: CAIN AR2A,(P) ;SKIP IF ANYTHING LEFT ON STACK TO MARK
JRST (T) ;ELSE RETURN
GCMRK8: POP P,A ;GET NEXT ITEM TO MARK
GCMRK1: HRRZS C,A ;ZERO LEFT HALF OF A, ALSO SAVE IN C
SETZ B,
LSHC A,-SEGLOG ;GET PAGE NUMBER OF ITEM (OTHER BITS GO INTO B)
SKIPL A,GCST(A) ;CHECK GCST ENTRY FOR THAT PAGE
JRST GCMKND ;NOT MARKABLE - IGNORE IT
TLNE A,GCBFOO ;MAYBE IT'S A VALUE CELL OR SYMBOL OR SAR
JRST GCMRK3 ;IF SO HANDLE IT SPECIALLY
LSHC A,SEGLOG-5 ;THIS GETS ADDRESS OF BIT WORD FOR THIS ITEM
ROT B,5 ;B TELLS US WHICH BIT (40/WD)
MOVE AR1,(A) ;GET WORD OF MARK BITS
TDZN AR1,GCBT(B) ;CLEAR THE ONE PARTICULAR BIT
JRST GCMKND ;QUIT IF ITEM ALREADY MARKED
MOVEM AR1,(A) ;ELSE SAVE BACK WORD OF BITS
JUMPGE A,GCMKND .SEE GCBCDR ;JUMP UNLESS MUST MARK THROUGH (REMEMBER THE LSHC)
HRR A,(C) ;GET CDR OF ITEM
TLNN A,GCBCAR←<SEGLOG-5> ;MAYBE WE ALSO WANT TO MARK THE CAR
JRST GCMRK1 ;NO - GO MARK CDR
PUSH P,A ;YES - SAVE CDR ON STACK
HLR A,(C) ;GET CAR OF ITEM AND GO MARK IT
IFE HNKLOG, JRST GCMRK1
IFN HNKLOG,[
TLNN A,GCBHNK←<SEGLOG-5>
JRST GCMRK1 ;ORDINARY LIST CELL
PUSH P,T ;FOR HUNK, SAVE T AND AR2A SO
HRLM AR2A,(P) ; CAN CALL GCMARK RECURSIVELY
MOVEI A,(C)
LSH A,-SEGLOG
HRRZ A,ST(A) ;GET TYPEP OF HUNK
2DIF [HRL C,(A)]GCHNLN,QHUNK0 ;C NOW HAS AOBJN POINTER
MOVEI AR2A,(P) ;SET UP AR2A FOR RECURSIVE GCMARK
GCMRK2: MOVEM C,-1(P) ;SAVE AOBJN POINTER IN SLOT PUSHED FOR CDR
HLRZ A,(C)
JUMPE A,GCMK2A
JSP T,GCMRK1 ;MARK ODD HUNK SLOT
MOVE C,-1(P)
GCMK2A: HRRZ A,(C)
JUMPE A,GCMK2B
JSP T,GCMRK1 ;MARK EVEN HUNK SLOT
MOVE C,-1(P)
GCMK2B: AOBJN C,GCMRK2
POP P,T ;RESTORE T AND AR2A
HLRZ AR2A,T
SUB P,R70+1 ;FLUSH AOBJN POINTER
JRST GCMKND
GCHNLN: -1
REPEAT HNKLOG, -<2←.RPCNT> ;LH'S FOR AOBJN POINTERS
] ;END OF IFN HNKLOG
;LSPGCM LSPGCS KLGCVC KLGCM1 KLGCND KLGCM2 KLGCSY KLGCSA ZZZ ZZZ KLGCSW KLGS1 KLGS1A KLGS1D
COMMENT | ONE OF THESE DAYS I'LL DEBUG THE MICROCODE FOR THIS - GLS
IFN ITS,[ IFE SEGLOG-11,[ IFLE HNKLOG-5,[
;;; MARK ROUTINE FOR USE WITH KL-10 MICROCODE
LSPGCM=:070000,,
LSPGCS=:071000,,
KLGCVC: SKIPA A,(A)
PUSH P,B
KLGCM1: LSPGCM A,KLGCM2
KLGCND: CAIN AR2A,(P)
JRST (T)
POP P,A
JRST KLGCM1
KLGCM2: JRST KLGCSY
JRST KLGCVC
JRST KLGCSA
REPEAT HNKLOG, JRST CONC KLGH,\.RPCNT+1
REPEAT 8-.+KLGCM2, .VALUE
KLGCSY: HLRZ AR1,(A)
TROE AR1,1
JRST KLGCND
HRLM AR1,(A)
PUSH P,(A)
PUSH P,(AR1)
HRRZ A,@-1(AR1)
JRST KLGCM1
KLGCSA: MOVSI AR1,TTS<GC>
IORM AR1,TTSAR(A)
JRST KLGCND
IFN HNKLOG,[
ZZZ==<1←HNKLOG>-1
REPEAT HNKLOG,[
CONC KLGH,\HNKLOG-.RPCNT,:
REPEAT 1←<HNKLOG-.RPCNT-1>,[
PUSH P,ZZZ(A)
HLRZ B,(P)
PUSH P,B
ZZZ==ZZZ-1
] ;END OF REPEAT 1←<HNKLOG-.RPCNT-1>
] ;END OF REPEAT HNKLOG
IFN ZZZ, WARN [YOU LOSE]
PUSH P,(A)
HLRZ A,(A)
JRST KLGCM1
] ;END OF IFN HNKLOG
KLGCSW: MOVNI T,3+BIGNUM ;SWEEP
KLGS1: SETZB C,AR1 ;ZERO FREELIST AND COUNT
SKIPN TT,FSSGLK+3+BIGNUM(T)
JRST KLGS1D
KLGS1A: MOVE B,GCST(TT)
LSH B,SEGLOG-5
TLZ B,-1
MOVEI A,(TT)
LSH A,SEGLOG
HRLI A,-SEGSIZ
LSPGCS A,1
LDB TT,[SEGBYT,,GCST(TT)]
JUMPN TT,KLGS1A
KLGS1D: MOVEM C,FFS+3+BIGNUM(T)
HRRM AR1,NFFS+3+BIGNUM(T)
AOJL T,KLGS1
JRST GCSW4A
]]] ;END OF IFLE HNKLOG-5, IFE SEGLOG-11, IFN ITS
| ;END OF COMMENT
;GSGEN RTSPC2 RTSP2A GGEN2 GGEN1 GFSPC GTSP5A BPSGC BPSGX
GSGEN: SKIPN AR2A,GCMKL ;GENERATE TAILS OF GCMKL AND APPLY
POPJ P, ;FUN IN AR1 TO THEM
PUSH P,AR1
MOVEI AR1,GCMKL
JRST GGEN1
RTSPC2: JUMPE A,GGEN2
RTSP2A: ADD D,TT
GGEN2: HRRZ AR2A,(AR2A) ;GENERAL LOOP FOR GSGEN
MOVEI AR1,(AR2A)
HRRZ AR2A,(AR2A)
GGEN1: JUMPE AR2A,POP1J ;TAIL OF GCMKL IN AR2A,
HRRZ A,(AR2A) ;SPACE OCCUPIED IN TT,
HLRZ A,(A) ;ALIVEP IN A
MOVE TT,(A)
HLRZ A,(AR2A)
HLRZ A,ASAR(A)
JRST @(P) ;ROUTINE WILL RETURN TO GGEN2
GFSPC: PUSH FXP,AR1
PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS
POP FXP,AR1
ADD D,@VBPORG ;NOW HAS TOTAL AMOUNT FREE IN BPS [COUNTING DEAD BLOCKS]
ADD D,GAMNT ;NOW DIMINISHED BY REQUESTED AMOUNT
CAMG D,BPSH
JRST GRELAR ;IF ENOUGH SPACE, THEN RELOCATE
JRST (R)
IFN PAGING,[
GTSP5A: SETZB A,TT ;GIVE OUT NIL AND 0 IF FAIL
JUMPLE AR1,CZECHI
PUSHJ P,BPSGC
JSP R,GFSPC
SETZ AR1,
JRST GTSP1B
] ;END OF IFN PAGING
BPSGC: PUSH FXP,NOQUIT ;SAVE CURRENT STATE OF FLAG
HLLZS NOQUIT ;FORCE OFF RIGHT HALFWORD
PUSH P,[444444,,BPSGX] ;MAGIC NUMBER,,RETURN ADR
JRST AGC
BPSGX: POP FXP,NOQUIT ;RESTORE OLD SETTING OF FLAGS
POPJ P,
;GCP8K GCP8J GCP8I GCP8G GCP8C GCP8B GCP8D GCP8H GCP8L GCP8L5 TWAP
;;; SOME ROUTINES FOR USE WITH GSGEN
GCP8K: HLRZ A,(D)
JSP T,GCMARK
GCP8J: HRRZ D,(D) ;MARK ATOMS ON OBLIST
GCP8I: JUMPE D,GCP8A ;WHICH HAVE NON-TRIVIAL
MOVE A,D ;P-LIST STRUCTURE.
JSP T,TWAP
JRST GCP8J
JRST GCP8K
JRST GCP8J
GCP8G: JUMPE D,GCP8A ;REMOVE T.W.A.'S FROM
MOVE A,D ;BUCKETS OF OBLIST.
JSP T,TWAP
JRST GCP8B
JRST GCP8B
HRRZ D,(D)
TLNE R,400000 ;BUCKET COMES FROM LH OF WORD IN OBARRAY
HRLM D,(F) ;IF AT THIS POINT R < 0
TLNN R,400000
HRRM D,(F)
JSP T,GCP8L
JRST GCP8G
GCP8C: HRRZ D,(D)
GCP8B: HRRZ A,(D)
GCP8D: JUMPE A,GCP8A
JSP T,TWAP
JRST GCP8C
JRST GCP8C
HRRZ A,(D)
HRRZ A,(A)
HRRM A,(D)
JSP T,GCP8L
JRST GCP8B
GCP8H: MOVE A,D ;MARK OBLIST BUCKET
JSP T,GCMARK
JRST GCP8A
GCP8L: JUMPE TT,(T) ;IF SCO REMOB'D, THEN REMOVE FROM SCO TABLE
HRRZ A,(TT)
JUMPN A,(T)
HLRZ A,(TT)
MOVE B,(A) ;MUST NOT BE INTERRUPTIBLE HERE
MOVEI A,0
LSHC A,7
JUMPN B,(T)
HRRZ TT,VOBARRAY
HRRZ TT,TTSAR(TT)
ADDI TT,<OBTSIZ+1>/2
ROT A,-1
ADD TT,A
JUMPL TT,GCP8L5
HRRZS (TT)
JRST (T)
GCP8L5: HLLZS (TT)
JRST (T)
TWAP: HLRZ A,(A)
JUMPE A,(T) ;NIL IS ALREADY MARKED
HLRZ TT,(A)
TRZE TT,1
JRST (T) ;NO SKIP IF ALREADY MARKED
MOVE B,SYMVC(TT)
MOVE TT,SYMARGS(TT)
TLNN B,SY.CCN\SY.PUR ;SKIP 1 IF SYMBOL HAS SOME NON-TRIVIAL
TLZE TT,-1 ;PROPERTIES: ARGS OR COMPILED CODE REFERENCE
JRST 1(T)
HRRZ B,(B)
HRRZ A,(A)
CAIN B,QUNBOUND
JUMPE A,2(T) ;SKIP 2 IF TRULY WORTHLESS SYMBOL,
; I.E., UNBOUND AND NO PROPERITES
JRST 1(T) ;SKIP 1 IF MEANINGFUL PROPERTIES OR VALUE
;STGPNT GCBT
;;; PRINT MESSAGE OF FORM "NNN[MM%] " FOR GC STATISTICS OUTPUT
STGPNT: PUSH FXP,F ;NEED TO SAVE F (IN CASE OF IFORCE)
PUSH FXP,T ;RECLAIMED AMNT IN T, TOTAL FOR SPACE IN TT
IMULI T,100.
IDIVM T,TT
EXCH TT,(FXP)
HRRZ AR1,VMSGFILES
TLO AR1,200000
MOVEI R,$TYO
IFE USELESS, MOVE C,@VBASE ;BASE HAD DAMNED WELL BETTER BE A FIXNUM
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN ;SKIPS
] ;END OF IFN USELESS
PUSHJ P,PRINI2
STRT 17,[SIXBIT \[!\] ;BEWARE THESE BRACKETS!!!!!
POP FXP,TT
IFE USELESS, MOVEI C,10.
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,[10.]
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI3 ;EFFECTIVELY, PRINI2 WITH *NOPOINT=T
STRT 17,[SIXBIT \%] !\] ;BEWARE THESE BRACKETS!!!!!
POP FXP,F
POPJ P,
;;; VERY IMPORTANT TABLE OF WORDS WITH SINGLE BITS!!! USED FOR MARKING!!!
GCBT: REPEAT 36., SETZ←-.RPCNT
;RETSP RTSP2 RTSP7 RTSP9 RTSP5 RTSPC1
IFN PAGING,[
SUBTTL RETURN CORE TO TIMESHARING SYSTEM
;;; HAIRY ROUTINE TO DECIDE WHETHER TO RETURN SOME BPS TO THE SYSTEM.
;;; MAY ONLY BE CALLED WHEN NOQUIT SPECIFIES NO INTERRUPTS.
RETSP:
10$ POPJ P, ;NOOP ON D10'S RUNNING PAGING LISP
IFE D10,[
MOVEI TT,4 ;GTSPC1 IS ALLOWED TO GRAB 4 PAGES
MOVEM TT,ARPGCT ; BEFORE INVOKING GC FOR LACK OF CORE
PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS
MOVE TT,BPSH
LSH TT,-PAGLOG ;CURRENT HIGHEST CORE BLOCK IN BPS
MOVE R,@VBPORG
ADDI R,1(D)
LSH R,-PAGLOG ;CORE NEEDED IF ARRAYS WERE PACKED
CAML R,TT
POPJ P,
LSH R,PAGLOG
ADDI R,PAGSIZ-1
HRLM R,RTSP1 ;NEW BPSH
SUB R,D
HRRM R,RTSP3 ;NEW BPEND
JUMPE D,RTSP5
HRLM D,RTSP3 ;NUMBER OF CELLS TO MOVE
PUSHJ P,GRELAR ;GRELAR LEAVES BPEND-AFTER-RELOCATION IN TT
HRL AR1,TT
HRR AR1,RTSP3 ;BLOCK PTR
SUBI TT,(AR1)
JUMPLE TT,RTSP2
MOVNI TT,1(TT)
HRRM TT,RTSP1
ADD AR1,R70+1
HLRZ C,RTSP3
ADD C,RTSP3
BLT AR1,(C)
MOVEI AR1,RTSPC1
PUSHJ P,GSGEN ;DO PATCH-UP ON ARRAY PARAMETERS
JSP T,RSXST ;????
RTSP2: HLRZ TT,RTSP1
MOVE R,TT
EXCH R,BPSH
HRRZ D,RTSP3
MOVEM D,@VBPEND
LSH R,-PAGLOG ;OLD CORE HIGHEST
LSH TT,-PAGLOG ;NEW CORE HIGHEST
MOVEI F,1(TT) ;MAKE UP A POINTER INTO THE PURTBL
ROT F,-4
ADDI F,(F)
ROT F,-1
TLC F,770000
ADD F,[450200,,PURTBL]
IT$ SUBM TT,R ;FOR ITS, MINUS THE NUMBER OF PAGES TO HACK
20$ SUBI R,(TT) ;FOR D20, THE POSITIVE NUMBER OF PAGES TO HACK
AOS D,TT
IFN ITS,[
HRLI TT,(R) ;-<NUMBER OF PAGES>,,<INITIAL PAGE NUMBER>
.CALL RTSP9 ;FLUSH THE PAGES
.LOSE 1000
] ;END OF IFN ITS
IFN D20,[
SETO 1, ;-1 MEANS DELETE PAGES
MOVSI 2,.FHSLF ;FROM SELF
HRRI 2,(TT) ;INITIAL PAGE NUMBER
MOVEI 3,(R) ;NUMBER OF PAGES
TLO 3,PM%CNT ;SET ITERATION BIT
PMAP
] ;END OF IFN D20
LSH D,-SEGLOG+PAGLOG
MOVE T,[$NXM,,QRANDOM] ;STANDARD ST ENTRY FOR A FLUSHED PAGE
RTSP7: TLNN F,730000
TLZ F,770000
IDPB NIL,F ;UPDATE PURTBL ENTRY FOR ONE PAGE
REPEAT SGS%PG, MOVEM T,ST+.RPCNT(D) ;UPDATE ST ENTRIES
ADDI D,SGS%PG
IT$ AOJL R,RTSP7
20$ SOJG R,RTSP7
POPJ P,
IFN ITS,[
RTSP9: SETZ
SIXBIT \CORBLK\ ;HACK PAGE MAP
1000,,0 ;DELETE PAGES
1000,,%JSELF ;FROM CURRENT JOB
400000,,TT ;AOBJN POINTER: -<COUNT>,,<PAGE NUMBER>
] ;END OF IFN ITS
RTSP5: SETZM GCMKL ;NO ARRAYS ALIVE
MOVE TT,R
PUSHJ P,BPNDST ;SETQ UP BPEND
JRST RTSP2
RTSPC1: JUMPE A,GGEN2
HRRE B,RTSP1 ;-<SIZE OF SHIFT + 1>
JSP AR1,GT3D
JRST GGEN2
] ;END IFE D10
] ;END OF IFN PAGING
;GTSPC1 GTSP1B GTSPC8 GTSPC2 GRELAR GREL1 CZECHI GTSPC8
SUBTTL GET SPACE FROM TIMESHARING SYSTEM
GTSPC1: HLLOS NOQUIT
JSP R,GFSPC ;SEE IF FREE SPACE ABOVE BPEND WILL ADD ENOUGH
IFN PAGING,[
SKIPLE AR1,ARPGCT
JRST GTSP1B
] ;END OF IFN PAGING
PUSHJ P,BPSGC ;WHEN COMPACTIFIED AND RELOCATED
JSP R,GFSPC ;IF NOT, GC AND TRY AGAIN
GTSP1B:
IFE PAGING,[
SETZB A,TT ;GIVE OUT NIL AND 0 IF WE FAIL
JRST CZECHI
] ;END OF IFE PAGING
IFN PAGING,[
CAML D,HINXM
JRST GTSP5A
MOVEI T,(D)
TRO T,PAGSIZ-1
MOVE R,BPSH
LSH D,-PAGLOG
LSH R,-PAGLOG
SUBM R,D ;NEGATIVE OF NUMBER OF PAGES TO GET
ADDM F,ARPGCT
MOVEI F,1(R) ;SET UP BYTE POINTER INTO PURTBL
ROT F,-4
ADDI F,(F)
ROT F,-1
TLC F,770000
ADD F,[450200,,PURTBL]
MOVEI TT,1(R)
LSH TT,-SEGLOG+PAGLOG
HLRZ AR1,(P) ;BEWARE! LH OF CALLING PDL SLOT = -1
TRNN AR1,1 ; MEANS THE GETSP FUNCTION IS CALLING
TROA AR1,3
MOVEI AR1,1
IFN ITS,[
HRLI R,(D)
HRRI R,1(R)
.CALL GTSPC8
.LOSE 1000
] ;END OF IFN ITS
IFN D20,[
PUSH P,D ;SAVE NEGATIVE COUNT
PUSH P,R ;AND SAVE CURRENT PAGE NUMBER
GTSPC8: AOS R,(P) ;GET NEXT PAGE NUMBER
LSH R,PAGLOG ;TURN INTO POINTER TO PAGE
SETMM (R) ;CREATE THE PAGE
MOVSI 1,.FHSLF ;OUR PROCESS
HRR 1,(P) ;CURRENT PAGE NUMBER
MOVSI 2,(PA%RD\PA%WT\PA%EX) ;READ, WRITE, EXECUTE
SPACS ;SET THEPAGE ACCESS
AOJL D,GTSPC8
POP P,R
POP P,D
] ;END OF IFN D20
MOVE A,[$XM,,QRANDOM]
GTSPC2: TLNN F,730000
TLZ F,770000
IDPB AR1,F ;UPDATE PURTBL ENTRY
REPEAT SGS%PG, MOVEM A,ST+.RPCNT(TT) ;UPDATE ST ENTRIES
ADDI TT,SGS%PG
AOJL D,GTSPC2
MOVEM T,BPSH ;FALLS INTO GRELAR
] ;END OF IFN PAGING
GRELAR: HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE.
HRRZ A,BPSH ;LEAVE BPEND-AFTER-RELOCATION AS RESULT
MOVEM A,GSBPN ;TEMPORARY BPEND
MOVEI AR1,GTSPC3
PUSHJ P,GSGEN ;RELOCATE ARRAYS
JSP T,RSXST
GREL1: MOVE TT,GSBPN
PUSHJ P,BPNDST
MOVE TT,(A)
CZECHI: HLLZS NOQUIT
JRST CHECKI ;CHECK FOR ↑G THEN POPJ P,
IFN ITS,[
GTSPC8: SETZ
SIXBIT \CORBLK\ ;HACK PAGE MAP
1000,,%CBNDR+%CBNDW ;NEED READ AND WRITE ACCESS
1000,,%JSELF ;FOR MYSELF
,,R ;AOBJN POINTER: -<COUNT>,,<PAGE NUMBER>
401000,,%JSNEW ;WANT FRESH PAGES
] ;END OF IFN ITS
;CNLAC BPNDST GTSPC3 GT3Z GT3H GT3B GT3A GT3C GT3D GT3D2 GT3G
SUBTTL ARRAY RELOCATOR
CNLAC: MOVEI D,0 ;COUNT NUMBER OF LIVING ARRAY CELLS, IN D
MOVEI AR1,RTSPC2
JRST GSGEN
BPNDST: JSP T,FIX1A ;STORE NEW VALUE FOR BPEND
MOVEM A,VBPEND
POPJ P,
;;; COMES HERE FROM GRELAR VIA GSGEN. AR2A HAS TAIL OF GCMKL, TT HAS TOTAL LENGTH OF ARRAY
GTSPC3: JUMPE A,GT3G ;RELOCATE AN ARRAY
MOVEI AR1,-1(TT) ;LENGTH-1 OF ARRAY IN AR1
HLRZ F,(AR2A)
HRRZ A,ASAR(F)
SUBI A,1 ;ARRAY AOBJN PTR LOC IN A.
MOVE C,GSBPN
SUBI C,(AR1)
MOVEM C,GSBPN ;LOC NEW BPTR IN C
MOVEI B,(C)
SUBI B,1(A) ;RELOCATION AMOUNT-1 IN B
CAML A,C ;IS ARRAY ALREADY IN PLACE?
JRST GT3C ;YES, SO EXIT
IFN D10,[
MOVE R,ASAR(F)
MOVE F,TTSAR(F)
TLNN R,AS.FIL ;IF THE ARRAY IS A FILE OBJECT,
JRST GT3H ; IS NOT CLOSED, AND HAS BUFFERS,
TLNN F,TTS.CL ; THEN WE MUST LET THE I/O COMPLETE
SKIPGE F.MODE(F) .SEE FBT.CM
JRST GT3H
IFE SAIL,[
TLNN F,TTS.IO ;OUTPUT?
JRST GT3Z ;NOPE, JUST WAIT
MOVE T,F.CHAN(F) ;GET CHANNEL NUMBER
LSH T,27
TLO T,(OUTPUT) ;FLUSH ALL OUTPUT BUFFERS
XCT T
] ;END IFE SAIL
GT3Z: MOVE F,F.CHAN(F)
LSH F,27
IOR F,[WAIT 0,] ;WAIT FOR THE I/O TO SETTLE DOWN
XCT F ; SO WE CAN RELOCATE THE BUFFERS
GT3H:
] ;END OF IFN D10
SUBI C,(AR1)
CAMGE A,C ;BEWARE: C COULD GO NEGATIVE!
JRST GT3A ;GOOD, EASY BLT
ADDI C,(AR1)
ADDI AR1,1(A) ;FIRST DESTINATION LOC
GT3B: HRRZI C,(AR1)
SUBI AR1,1(B) ;CONSTRUCT SOURCE ADDRESS
HRLI C,(AR1)
HRRZI T,(C)
ADDI T,(B)
BLT C,(T) ;SERIES OF SMALL BLTS
CAMLE AR1,GSBPN
JRST GT3B
ADDI AR1,(B)
SUB AR1,GSBPN
MOVE A,GSBPN
SUBI A,1(B)
GT3A: MOVE C,GSBPN
ADDI AR1,(C)
HRL C,A
BLT C,(AR1) ;FINAL (OR ONLY) BLT
JSP AR1,GT3D
GT3C: SOS GSBPN
JRST GGEN2
GT3D: ADDI B,1
HLRZ A,(AR2A)
ADDM B,ASAR(A) ;UPDATE ARRAY POINTERS BY OFFSET IN B
ADDM B,TTSAR(A)
MOVE C,ASAR(A)
ADDM B,-1(C) ;UPDATE AOBJN PTR BEFORE ARRAY HEADER
HRR C,TTSAR(A) ;FOR A BUFFERED FILE OBJECT, WE MUST
TLNE C,AS.FIL ; RELOCATE CERTAIN ADDRESSES IN THE ARRAY DATA
SKIPGE F.MODE(C) .SEE FBT.CM
JRST (AR1)
MOVE C,TTSAR(A)
IFN ITS+D20,[
ADDM B,FB.IBP(C)
ADDM B,FB.BP(C)
] ;END OF ITS+D20
IFN D10,[
TLNE C,TTS.CL ;DON'T HACK WITH CLOSED FILE OBJECTS
JRST (AR1)
MOVE F,FB.HED(C)
ADDM B,(F) ;UPDATE CURRENT BUFFER ADDRESS
ADDM B,1(F) ;UPDATE BYTE POINTER
HRRZ F,(F)
MOVE R,F
GT3D2: ADDM B,(R) ;UPDATE BUFFER RING POINTERS
HRRZ R,(R)
CAIE R,(F) ;DONE WHEN WE HAVE GONE AROUND THE RING
JRST GT3D2
IFN SAIL,[
MOVE R,F.CHAN(C) ;GET CHANNEL NUMBER
LSH R,27
HRR R,FB.HED(C) ;POINTER TO BUFFER HEADER
HRR R,(R) ;GET CURRENT ADR OF BUFFER
TLNN C,TTS.IO ;DO APPROPRIATE UUO TO MOVE BUFFER
TLOA R,(INPUT)
TLO R,(OUTPUT)
XCT R
] ;END IFN SAIL
] ;END OF IFN D10
JRST (AR1)
GT3G: HRRZ AR2A,(AR2A)
HRRZ AR2A,(AR2A)
HRRM AR2A,(AR1) ;CUT OUT DEAD BLOCK
JRST GGEN1
PGTOP GC,[GARBAGE COLLECTOR]
;PURCOPY PCOPY9 PCOPLS PCONS PCOPFX PFXCONS PFXC1 PFXC3
;;; ********** MEMORY MANAGEMENT, ETC **********
SUBTTL PURCOPY FUNCTION
PGBOT BIB
PURCOPY:
PUSHJ FXP,SAV5M2
PUSH P,[RST5M2]
PUSH FXP,CCPOPJ
PUSHJ P,SAVX5
PUSH P,[RSTX5]
MOVEI TT,(A) ;USES A,B,T,TT
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,PUR
POPJ P,
2DIF JRST (TT),PCOPY9,QLIST .SEE STDISP
PCOPY9: JRST PCOPLS ;LIST
JRST PCOPFX ;FIXNUM
JRST PCOPFL ;FLONUM
DB$ JRST PCOPDB ;DOUBLE
CX$ JRST PCOPCX ;COMPLEX
DX$ JRST PCOPDX ;DUPLEX
BG$ JRST PCOPBN ;BIGNUM
JRST PCOPSY ;SYMBOL
HN$ REPEAT HNKLOG+1, JRST PCOPHN ;HUNKS
POPJ P, ;RANDOM
MOVSI TT,100 ;ARRAY
IFN .-PCOPY9-NTYPES, WARN [WRONG LENGTH TABLE]
IORM TT,(A) ;SET "COMPILED CODE NEEDS ME" BIT
POPJ P,
PCOPLS: HLRZ B,(A) ;PURCOPY A LIST ALREADY
PUSH P,B
HRRZ A,(A)
SKIPE A ;NEVER PURCOPY NIL
PUSHJ P,PURCOPY
EXCH A,(P)
SKIPE A ;NEVER PURCOPY NIL
PUSHJ P,PURCOPY
POP P,B
PCONS: AOSL TT,NPFFS ;PURE FS CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG ;NOTE: CLOBBERS TT
ADD TT,EPFFS
NOPRO
HRLM A,(TT)
HRRM B,(TT)
MOVEI A,(TT)
POPJ P,
PCOPFX: MOVE TT,(A)
PFXCONS: CAIGE TT,XHINUM ;PURE FIXNUM CONSER
CAMGE TT,[-XLONUM]
JRST PFXC1
MOVEI A,IN0(TT)
POPJ P, ;NOTE: EXITS WITH POPJ P,!!!
PFXC1: AOSL A,NPFFX
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD A,EPFFX
NOPRO
PFXC3: MOVEM TT,(A)
POPJ P,
;PCOPFL PFLCONS PCOPCX PCXCONS PCOPDB PDBCONS PDBC3 PCOPDX PDXCONS PCOPBN PBNCONS
PCOPFL: MOVE TT,(A)
PFLCONS: AOSL A,NPFFL ;PURE FLONUM CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD A,EPFFL
NOPRO
JRST PFXC3 ;ALSO EXITS WITH POPJ P,!!!
IFN CXFLAG,[
PCOPCX:
KA MOVE D,1(A)
KA MOVE TT,(A)
KIKL DMOVE TT,(A)
PCXCONS: AOSL A,NPFFC
SPECPRO INTPPC
PUSHJ P,GTNPSG
XCTPRO
MOVEI T,1(A)
MOVEM T,NPFFC
ADD A,EPFFC
NOPRO
DB% JRST PDBC3 ;WILL DROP IN IF NO DOUBLES
] ;END OF IFN CXFLAG
IFN DBFLAG,[
PCOPDB:
KA MOVE D,1(A)
KA MOVE TT,(A)
KIKL DMOVE TT,(A)
PDBCONS: AOSL A,NPFFD
SPECPRO INTPPC
PUSHJ P,GTNPSG
XCTPRO
MOVEI T,1(A)
MOVEM T,NPFFD
ADD A,EPFFD
NOPRO
] ;END OF IFN DBFLAG
IFN DBFLAG+CXFLAG,[
PDBC3:
KA MOVEM D,1(A)
KA JRST PFXC3
KIKL DMOVEM TT,(A)
KIKL POPJ P,
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
PCOPDX:
KA REPEAT 4, MOVE TT+<2#.RPCNT>,.RPCNT
KIKL DMOVE R,(A)
KIKL DMOVE TT,2(A)
PDXCONS: AOSL A,NPFFZ
SPECPRO INTPPC
PUSHJ P,GTNPSG
XCTPRO
MOVEI T,3(A)
MOVEM T,NPFFZ
ADD A,EPFFZ
NOPRO
KA REPEAT 4, MOVEM TT+<2#.RPCNT>,.RPCNT
KIKL DMOVEM R,(A)
KIKL DMOVEM TT,2(A)
POPJ P,
] ;END OF IFN DBFLAG
IFN BIGNUM,[
PCOPBN: PUSH P,(A)
HRRZ A,(A)
PUSHJ P,PURCOPY
HLL A,(P)
SUB P,R70+1
PBNCONS: AOSL TT,NPFFB ;PURE BIGNUM CONSER
SPECPRO INTPPC
PUSHJ P,GTNPSG
ADD TT,EPFFB
NOPRO
MOVEM A,(TT)
MOVEI A,(TT)
POPJ P,
] ;END OF IFN BIGNUM
;PCOPSY PCOPS1 PCOPS3 PCOPHN PCOPH3
PCOPSY: PUSH P,A ;SAVE POINTER TO SYMBOL
HLRZ B,(A) ;FETCH POINTER TO SYMBOL BLOCK
MOVE TT,SYMVC(B)
TLNE TT,SY.PUR ;IF ALREADY PURE IGNORE COMPLETELY
JRST PCOPS1
PUSH P,B ;SAVE SYMVC ADR
HRRZ A,SYMPNAME(B)
PUSHJ P,PURCOPY ;PURCOPY THE PNAME
PUSHJ P,PSYCONS ;GET A PURE SY2 BLOCK
POP P,B ;RESTORE SYMVC ADR
HLRZ A,(A) ;GET POINTER TO PURE SY2
HRRZ TT,SYMVC(B) ;GET THE VALUE CELL
HRRM TT,SYMVC(A) ;COPY INTO NEW PURE SY2
HLLZ TT,SYMARGS(B) ;ALSO COPY THE ARGS PROPERTY
HLLM TT,SYMARGS(A)
XCTPRO
HLRZ B,@(P) ;GET POINTER TO OLD SY2
EXCH B,FFY2 ;THIS IS NEW HEAD OF FREELIST, GET OLD HEAD
MOVEM B,@FFY2 ;PLACE CHAIN IN NEWLY FREED CELL
NOPRO
HRLM A,@(P) ;STORE POINTER TO NEW SY2 BLOCK
PCOPS1: LOCKI
HRRZ A,(P) ;GET POINTER TO SYMBOL
PUSHJ P,SYMHSH ;GET HASH VALUE
IDIVI T,OBTSIZ ;MAKE POINTER INTO OBARRAY
PUSH FXP,TT
MOVEI A,(FXP)
MOVE T,VOBARRAY
PUSHJ P,@ASAR(T) ;BUCKET ADR
MOVEI B,(A)
HRRZ A,(P)
PUSHJ P,MEMQ1 ;FIND ACTUAL ATOM
POP FXP,D
JUMPN A,PCOPS3 ;IF IN OBARRAY NO NEED TO GCPROTECT
MOVEI T,1 ;GCPROTECT
HRRZ A,(P)
PUSHJ P,.GCPRO
PCOPS3: UNLOCKI ;CLEANUP AND GO HOME
JRST POPAJ
IFN HNKLOG,[
PCOPHN: SKIPN VHUNKP ;TREAT HUNKS AS LISTS IF HUNKP IS NIL
JRST PCOPLS
2DIF [HRRZ B,(TT)]GCWORN,QLIST
PUSH P,B .SEE INTXCT ;CAN'T USE FXP
2DIF [AOSL B,(TT)]NPFFS,QLIST ;THIS WORD SERVES AS ARG TO GTNPSG
SPECPRO INTPPC
PUSHJ P,GTNPSG
XCTPRO
MOVE D,B
ADD D,(P)
SOS D ;SINCE ALREADY AOS'ED ONCE
2DIF [MOVEM D,(TT)]NPFFS,QLIST
NOPRO
2DIF [ADD B,(TT)]EPFFS,QLIST ;B NOW HAS ADDRESS OF FRESH PURE HUNK
PUSH P,A
PUSH P,B
MOVE D,-2(P)
PCOPH3: ADD D,-1(P) ;WE SCAN THE OLD HUNK FROM THE END BACKWARDS
HLRZ B,-1(D) ;GOBBLE A CAR AND A CDR
HRRZ A,-1(D)
PUSH P,B
PUSHJ P,PURCOPY ;PURCOPY THE CDR
EXCH A,(P)
PUSHJ P,PURCOPY ;PURCOPY THE CAR
HRLM A,(P)
MOVE D,-1(P) ;CALCULATE PLACE IN NEW HUNK
ADD D,-3(P)
POP P,-1(D) ;POP COPIED CAR/CDR PAIR INTO PURE HUNK
SOSE D,-2(P)
JRST PCOPH3
POP P,A ;RETURN NEW HUNK
SUB P,R70+2
POPJ P,
] ;END OF IFN HNKLOG
;GETCOR GTCOR4 GTCOR6 LHVB0 LHVBAR LHVB3 LHVB4 LHVB1
IFN PAGING,[
SUBTTL GETCOR
;;; THIS ROUTINE IS SPECIFICALLY FOR PEOPLE WHO HAND-CODE LAP.
;;; IT IS USED TO ALLOCATE A NUMBER OF CONSECUTIVE PAGES
;;; OF MEMORY FOR VARIOUS PURPOSES, E.G. HACKING OF PDP-11'S
;;; OR INFERIOR JOBS OR WHATEVER.
;;; THE NUMBER OF PAGES DESIRED SHOULD BE IN TT; THE LOW ADDRESS
;;; OF THE PAGES IS RETURNED IN TT, OR ZERO FOR FAILURE.
;;; THIS ROUTINE DOES NOT ACTUALLY GET CORE; IT MERELY RESERVES
;;; ADDRESS SPACE.
;;; THERE IS CURRENTLY NO PROVISION FOR RETURNING THE MEMORY GRABBED.
GETCOR: HLLOS NOQUIT
LSH TT,PAGLOG
MOVE T,HINXM
SUBI T,(TT)
CAMGE T,BPSH
JRST GTCOR6
MOVEI F,(TT) ;GETTING F THIS WAY FLUSHES
LSH F,-PAGLOG ; RANDOM BITS. (IT'S SAFER.)
GTCOR4: PUSHJ P,ALIMPG
.VALUE ;HOW CAN WE LOSE HERE?
SOJG F,GTCOR4
SKIPA TT,HINXM
GTCOR6: TDZA TT,TT ;LOSE, LOSE, LOSE
ADDI TT,1
JRST CZECHI
IFN LHFLAG,[
LHVB0: WTA [BAD SIZE - LH↑<!] ;↑< = |
LHVBAR: CAIL B,QLIST ;SUBR 2
CAILE B,QARRAY ;GROSS KLUDGE FOR LH
JRST LHVB1
JSP T,FXNV1
TLNE TT,-1
JRST LHVB0
ADDI TT,PAGSIZ-1
IDIVI TT,PAGSIZ
MOVNI AR2A,(TT)
PUSHJ P,GETCOR
JUMPE TT,FIX1
CAIE B,QARRAY
CAIN B,QRANDOM
XORI B,QARRAY#QRANDOM ;GROSS KLUDGE
MOVEI D,(TT)
LSH D,-SEGLOG
IMULI AR2A,SGS%PG
HRLI D,(AR2A)
2DIF [MOVE R,(B)]GCWORS,QLIST
LHVB3: MOVEM R,ST(D)
SETZM GCST(D)
TLNN R,$FS+BN+HNK
JRST LHVB4
MOVE T,LHSGLK
DPB T,[SEGBYT,,GCST(D)]
HRRZM D,LHSGLK
LHVB4: AOBJN D,LHVB3
JRST FIX1
LHVB1: EXCH A,B
WTA [BAD SPACE - LH↑<!] ;↑< = |
EXCH A,B
JRST LHVBAR
] ;END OF IFN LHFLAG
;PDLST0 PDLST8
;;; IFN PAGING
SUBTTL PDL OVERFLOW HANDLER
;;; CALL BY JSR PDLSTH
;;; F HAS THE ADDRESS OF THE AC HOLDING THE PDL POINTER.
;;; D HAS AN ADDRESS WITHIN THE PAGE TO GET.
;;; R MAY BE USED AS SCRATCH.
;PDLSTH: 0 ;HACK ST FOR ADDING PDL PAGES
PDLST0:
LSH D,-PAGLOG
IFN ITS,[
.CALL PDLST8
.LOSE 1000
] ;END OF IFN ITS
IFN D20,[
MOVEM A,PDLSTA ;SAVE AWAY AC'S SO CAN DO A JSYS
MOVEM B,PDLSTB
MOVEM C,PDLSTC
MOVEI 1,.FHSLF ;DISABLE INTERRUPT FOR OURSELVES
MOVE 2,[<1←<35.-.ICNXP>>] ;WE CAN'T HANDLE THE NXP TRAP THIS WILL CAUSE
DIC
MOVEI 1,(D) ;PAGE NUMBER
LSH 1,PAGLOG ;MAKE AN ADDRESS
SETMM (1) ;CREATE THE PAGE
MOVSI 1,.FHSLF ;CHANGE ACCESS FOR OUR PROCESS
HRRI 1,(D) ;THE PAGE WE JUST CREATED
MOVSI 2,(PA%RD\PA%WT\PA%EX)
SPACS
MOVEI 1,.FHSLF ;REEANBLE NXP TRAPS
MOVE 2,[<1←<35.-.ICNXP>>]
AIC
MOVE C,PDLSTC ;RESTORE AC'S
MOVE B,PDLSTB
MOVE A,PDLSTA
] ;END OF IFN D20
MOVEI R,(D) ;CALCULATE PURTBL BYTE POINTER
ROT R,-4
ADDI R,(R)
ROT R,-1
TLC R,770000
ADD R,[430200,,PURTBL]
MOVSS D
HRRI D,3
DPB D,R ;UPDATE PURTBL
LSH D,-22+PAGLOG-SEGLOG ;HORRIBLE HACKERY TO UPDATE ST
ADD D,[-<SGS%PG+1>,,ST-1] ; WITHOUT AN EXTRA AC:
REPEAT SGS%PG, PUSH D,PDLST9-P(F) ; USE PUSHES! (CAN'T OVERFLOW)
JRST @PDLSTH
IFN ITS,[
PDLST8: SETZ
SIXBIT \CORBLK\ ;HACK PAGE MAP
1000,,%CBNDR+%CBNDW ;GET READ AND WRITE ACCESS
1000,,%JSELF ;FOR MYSELF
,,D ;PAGE NUMBER
401000,,%JSNEW ;GET FRESH PAGE
] ;END OF IFN ITS
;PDLOV PDLH0A PDLH2 PDLH2A PDLH2B PDLH3A PDLH4
;;; IFN PAGING
;;; HAIRY PDL OVERFLOW HANDLER
PDLOV: MOVE F,INTPDL
MOVEM D,IPSWD2(F) ;SAVE D
MOVEM R,IPSWD1(F) ;SAVE R
SKIPL INTPDL
.VALUE ;I WANT TO SEE THIS! - GLS
MOVEI F,P ;ALL RIGHT THEN, LET'S PLAY
JUMPGE P,PDLH0A ; TWENTY QUESTIONS - IS IT REGPDL?
MOVEI F,SP
JUMPGE SP,PDLH0A ;SPECPDL?
MOVEI F,FXP
JUMPGE FXP,PDLH0A ;FXP?
MOVEI F,FLP ;IF NOT FLP, THEN IT'S PRETTY RANDOM
JUMPGE FLP,PDLH0A
HLRZ R,NOQUIT
JUMPN R,PDLH3A
LERR [SIXBIT \RANDOM PDL OVERFLOW!\]
PDLH0A: HRRZ R,(F) ;FETCH RIGHT HALF OF PDL POINTER
MOVEI D,(R)
CAML R,OC2-P(F) ;IF WE'RE OVER THE ORIGIN OF THE
JRST PDLH5 ; OVERFLOW PDL, THEN ERROR OUT
HLRZ R,F
ADDI R,11(D) ;HERE IS A HACK TO PAGIFY
IORI R,PAGSIZ-1 ; UPWARDS, BUT KEEP WELL AWAY
SUBI R,10 ; FROM THE PAGE BOUNDARY
CAML R,OC2-P(F) ;IF WE'RE ABOVE THE OVERFLOW PDL,
MOVE R,OC2-P(F) ; ONLY INCREASE TO THAT PLACE
CAMGE D,ZPDL-P(F) ;SKIP IF WE'RE ABOVE PDLMAX
JRST PDLH2 ; PARAMETER FOR THIS PDL
TLO F,-1 ;SET FLAG TO INDICATE THIS FACT
MOVE D,MORPDL-P(F) ;PUSH UP THE PDLMAX
ADD D,ZPDL-P(F) ; "SOME MORE"
ANDI D,777760 ;BUT KEEP AWAY FROM PAGE
TRNN D,PAGKSM ; BOUNDARY (PICKY, PICKY!)
SUBI D,20
MOVEM D,ZPDL-P(F)
HRRZ D,(F)
JRST PDLH2A
PDLH2: TLZE F,-1
JRST PDLH2B
CAMLE R,ZPDL-P(F) ;IF OUR GUESS WOULD PUT US OVER
PDLH2A: MOVE R,ZPDL-P(F) ; PDLMAX, GO ONLY AS FAR AS THAT
PDLH2B: SUBI D,(R) ;CALCULATE NEW LEFT HALF FOR PDL PTR
HRLM D,(F) ;CLOBBER INTO PDL PTR
HRRZ D,(F) ;FIGURE OUT IF WE NEED TOP GET
ADDI R,10 ; MORE CORE FOR ALL THIS
ANDI R,PAGMSK
EXCH R,D
CAIG R,(D) ;SKIP IF WE CROSSED NO PAGE BOUNDARY
JSR PDLSTH ;ELSE MUST GET NEW PAGE AND UPDATE ST
TLZN F,-1 ;SKIP IF WE WERE ABOVE PDLMAX
JRST PDLH3A
MOVSI D,QREGPDL-P(F)
HRRI D,1005 ;PDL-OVERFLOW
HRRZ R,INTPDL
HRRZ R,IPSPC(R)
CAIL R,UINT0 ;AVOID DEEP INTERRUPT RECURSION:
CAILE R,EUINT0 ; IF PDL OVERFLOWED WITHIN UINT0,
JRST PDLH4 ; THEN JUST STACK UP THE INTERRUPT,
JSR UISTAK ; AND SOMEONE WILL EVENTUALLY TRY CHECKI
PDLH3A: HRRZ F,INTPDL
JRST INTXT2
PDLH4: MOVE R,FXP ;ELSE TRY TO GIVE A PDL OVERFLOW
SKIPE GCFXP ; USER INTERRUPT IMMEDIATELY
MOVE FXP,GCFXP ;REMEMBER, PDL OVERFLOW IS NOT
PUSH FXP,R ; DISABLED INSIDE THE PDL
PUSHJ FXP,$IWAIT ; OVERFLOW HANDLER!!!
JRST XUINT
JRST INTXIT
;MORPDL PDLMSG PDLST9 PDLH5 PDLH6
;;; IFN PAGING
MORPDL: 400 ;AMOUNTS TO INCREMENT PDLS BY
100 ; WHEN OVERFLOW OCCURS (THIS GIVES
LSWS+100 ; LOSER A CHANCE TO SSTATUS PDLMAX,
200 ; AT LEAST)
PDLMSG: POVPDL ;REG
POVFLP ;FLONUM
POVFXP ;FIXNUM
POVSPDL ;SPEC
PDLST9: $XM,,QRANDOM ;TYPICAL ST ENTRIES FOR PDL PAGES
FL+$PDLNM,,QFLONUM
FX+$PDLNM,,QFIXNUM
$XM,,QRANDOM
PDLH5: IORI R,PAGSIZ-1 ;BAD PDL OV - REALLY DESPERATE
SUBI D,-2(R) ;GIVE US AS MUCH PDL AS IS LEFT
JUMPL D,PDLH6
MOVE P,C2
MOVE FXP,FXC2
SETZM TTYOFF
STRT UNRECOV
STRT @PDLMSG-P(F)
JRST DIE
PDLH6: HRLM D,(F)
HLRZ R,NOQUIT
JUMPN R,GCPDLOV ;FOO! HAPPENED IN GC - BOMB OUT!
HRRZ B,PDLMSG-P(F)
CAIE B,POVSPDL
JRST PDLOV5 ;PDLOV5 HANDLE WILL GET US TO TOP LEVEL
MOVEM P,F ;FOR SP, TRY TO POP BINDINGS FIRST
HRRZ TT,SPSV ; SO *RSET-TRAP WON'T OVERFLOW
MOVE P,[-LFAKP-1,,FAKP] ;SO WE HAVE ENOUGH PDL FOR UBD
PUSH P,FXP
MOVE FXP,[-LFAKFXP-1,,FAKFXP]
PUSHJ P,UBD
POP P,FXP
MOVE P,F
JRST PDLOV5 ;PDLOV5 WILL SET UP PDLS
] ;END OF IFN PAGING
;GRBPSG GTNPSG GTNPS8
SUBTTL PURE SEGMENT CONSER
;;; GRBPSG RETURNS ONE PUREIFIABLE SEGMENT. ADR IN AC T
;;; GTNPSG IS INVOKED AS FOLLOWS:
;;; AOSL A,NPFF% ;SKIP UNLESS NO MORE LEFT
;;; SPECPRO INTPPC
;;; PUSHJ P,GTNPSG ;MUST GET MORE
;;; ADD A,EPFF% ;ELSE JUST FIGURE OUT ABSOLUTE ADDRESS
;;; NOPRO
;;; WHERE % IS SOME APPROPRIATE LETTER (E.G. S, X, L, B).
;;; GTNPSG UPDATES NPFF% AND EPFF% BY LOOKING AT THE AOSL, THEN
;;; RETURNS TO THE AOSL.
XCTPRO
GRBPSG: HLLOS NOQUIT ;GET NEW PURE SEGMENT
NOPRO
SAVEFX TT D R
SKIPN T,PRSGLK ;SKIP IF ANY SEGMENTS IN PURE SEGMENT FREELIST
PUSHJ P,GTNPS3
LDB D,[SEGBYT,,GCST(T)] ;IF SO, CDR THAT FREELIST
MOVEM D,PRSGLK
MOVE TT,[$XM+PUR,,QRANDOM]
MOVEM TT,ST(T) ;SETUP ST TABLE CORRECTLY
SETZM GCST(T) ;AND ALSO GCST
RSTRFX R D TT
JRST CZECHI
;GETS A PURE SEGMENT FOR CONSING PURPOSES
XCTPRO
GTNPSG: HLLOS NOQUIT ;GET NEW PURE SEGMENT
NOPRO
REPEAT 2, SOS (P) ;BACK UP RETURN ADDRESS TO PRECEDING INST
SAVEFX T TT D R
SKIPN T,PRSGLK ;SKIP IF ANY SEGMENTS IN PURE SEGMENT FREELIST
PUSHJ P,GTNPS3
LDB D,[SEGBYT,,GCST(T)] ;IF SO, CDR THAT FREELIST
MOVEM D,PRSGLK
IFE HNKLOG, MOVE D,@(P) ;NOW D POINTS TO NPFF-
IFN HNKLOG,[
MOVE D,(P) ;THIS ALLOWS REFERENCE TO NPFF- TO BE INDEXED
MOVEI D,@(D) ; BY TT, WHICH MUST BE SAFE TO THIS POINT
] ;END OF IFN HNKLOG
2DIF [SKIPN TT,(D)]GTNPS8,NPFFS
.VALUE
MOVEM TT,ST(T)
SETZM GCST(T)
LSH T,SEGLOG
ADDI T,SEGSIZ
MOVEM T,EPFFS-NPFFS(D) ;UPDATE PARAMETERS FOR NEW PURE SEGMENT
MOVNI T,SEGSIZ+1
MOVEM T,(D)
MOVEI T,SEGSIZ
ADDM T,PFSSIZ-NPFFS(D) ;UPDATE STORAGE SIZE
RSTRFX R D TT T
JRST CZECHI
;;; TYPICAL ST ENTRIES FOR PURE SEGMENTS
GTNPS8: LS+$FS+PUR,,QLIST ;LIST
FX+PUR,,QFIXNUM ;FIXNUM
FL+PUR,,QFLONUM ;FLONUM
DB$ DB+PUR,,QDOUBLE ;DOUBLE
CX$ CX+PUR,,QCOMPLEX ;COMPLEX
DX$ DX+PUR,,QDUPLEX ;DUPLEX
BG$ BN+PUR,,QBIGNUM ;BIGNUM
0 ;NO PURE SYMBOLS
HN$ REPEAT HNKLOG+1, LS+HNK+PUR,,QHUNK0+.RPCNT ;HUNKS
0 ;NO PURE SARS
IFN .-GTNPS8-NFF, WARN [GTNPS8 WRONG LENGTH TABLE]
$XM+PUR,,QRANDOM ;SYMBOL BLOCKS
;GTNPS3
;CALLED TO GET NEW PAGE OF PURE MEMORY
;RETURNS C(PRSGLK) IN T
GTNPS3: PUSH FXP,TT ;GTNPSG REQUIRES TT TO BE SAFE
IFN PAGING,[
MOVE T,HINXM ;FIGURE OUT IF ANY ROOM LEFT
SUBI T,PAGSIZ
CAMGE T,BPSH
LERR [SIXBIT \NO SPACE FOR NEW PURE PAGE!\]
MOVEM T,HINXM ;UPDATE HINXM
MOVEI TT,1(T)
] ;END OF IFN PAGING
IFE PAGING,[
MOVE TT,HIXM
ADDI TT,PAGSIZ
CAMLE TT,MAXNXM
LERR [SIXBIT \NO SPACE FOR NEW PURE PAGE!\]
MOVEM TT,HIXM
] ;END OF IFE PAGING
LSH TT,-SEGLOG ;UPDATE ST AND GCST FOR NEW PAGE
MOVE D,[$XM+PUR,,QRANDOM]
REPEAT SGS%PG, MOVEM D,ST+.RPCNT(TT)
MOVE D,PRSGLK
REPEAT SGS%PG,[
SETZM GCST+.RPCNT(TT)
DPB D,[SEGBYT,,GCST+.RPCNT(TT)]
MOVEI D,.RPCNT(TT)
] ;END OF REPEAT SGS%PG
MOVEM D,PRSGLK
IFN PAGING,[
MOVEI TT,1(T) ;UPDATE PURTBL
ROT TT,-PAGLOG-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[430200,,PURTBL]
DPB T,TT ;T HAS 11 IN LOW TWO BITS
; (CAN PURIFY, WITH SOME CARE)
IFN ITS,[
MOVEI R,1(T) ;NOT AN AOBJN POINTER,
LSH R,-PAGLOG ; SO WE GET ONLY ONE PAGE
.CALL GTSPC8
.LOSE 1000
] ;END OF IFN ITS
IFN D20,[
PUSHJ FXP,SAV3
SETMM 1(T) ;CREATE THE PAGE
MOVEI 1,1(T) ;THEN GET THE PAGE NUMBER
LSH 1,-PAGLOG
HRLI 1,.FHSLF
MOVSI 2,(PA%RD\PA%WT\PA%EX)
SPACS
PUSHJ FXP,RST3
] ;END OF IFN D20
] ;END OF IFN PAGING
IFN <PAGING-1>*D10,[
HRRZ TT,HIXM
CORE TT,
HALT
] ;END OF IFN <PAGING-1>*D10
MOVE T,PRSGLK ;FORCE PRSGLK INTO AC T FOR CALLER
POP FXP,TT
POPJ P,
;GCGRAB GCGRB1
SUBTTL FREE STORAGE SPACE EXPANSION
;;; THIS PORTION OF THE GARBAGE COLLECTOR DETERMINES WHETHER
;;; WE SHOULD JUST GRAB A NEW SEGMENT OF FREE STORAGE FOR SOME
;;; CONSER, OR DO A FULL-BLOWN GARBAGE COLLECTION. IT IS
;;; CONTROLLED BY PARAMETERS SETTABLE VIA (SSTATUS GCSIZE ...).
GCGRAB: MOVN R,D
JFFO R,.+1 ;DETERMINE WHICH SPACE WANTED MORE
SUBI F,NFF
MOVEI AR2A,1 ;MACRAK SEZ: GRAB JUST ONE
SKIPN FFY2
SETZ F,
JUMPE F,GCGRB1 ; ... SEZ MACRAK
MOVE D,SFSSIZ+NFF(F)
CAML D,GFSSIZ+NFF(F) ;CAN'T JUST GRAB IF ABOVE SIZE
JRST AGC1Q ; SPECIFIED FOR "FREE GRABBIES"
MOVE D,GFSSIZ+NFF(F)
CAMLE D,XFFS+NFF(F) ;CAN'T GRAB IF IT WOULD PUT
JRST AGC1Q ; US ABOVE THE MAXIMUM SIZE
GCGRB1: PUSH FXP,AR2A
PUSHJ P,GRABWORRY
POP FXP,AR1
JUMPGE AR2A,AGC1Q ;GO DO FULL-BLOWN GC AFTER ALL
IFN WHL,[
MOVE D,[-3,,GCWHL6]
MOVE R,GCWHO
TRNE R,1
.SUSET D
] ;END OF IFN WHL
JRST GCEND
;GRBSEG GRBSG1 GCWORRY GRABWORRY GCWR0A GCWR0B GCWOR2 GCWR2A GCWR2B
;;; THESE ROUTINES WORRY ABOUT GETTING A NEW IMPURE FREE STORAGE
;;; SEGMENT. (FOR PURE FREE STORAGE SEGMENTS, SEE GTNPSG.)
;;; GCWORRY MUST DO SPECIAL HACKERY FOR SYMBOL AND SAR SPACES, SINCE THEY
;;; REQUIRE MORE THAN ONE CONSECUTIVE SEGMENT, AND PRINTS OUT PRETTY
;;; MESSAGES IF GCGAG IS NON-NIL. MUST HAVE NOQUIT NON-ZERO.
;;; *THE FOLLOWING COMMENT IS HISTORICAL AND SHOULD BE IGNORED*
;;; MUST HAVE NOQUIT NON-ZERO AND ST/GCST PAGES IMPURE WHEN ENTERING!
;THIS ROUTINE ALLOCATES ONE IMPURE SEGMENT AND MARKS IT AS
; $XM,,QRANDOM IN ST TABLE. POINTER TO SEGMENT RETURNED IN TT
; DESTROYS C, D, AR1, R
GRBSEG: SKIPE TT,IMSGLK
JRST GRBSG1 ;JUMP IF ANY SEGMENTS AVAILABLE
PUSHJ P,ALIMPG ;ELSE MUST GRAB A NEW PAGE
POPJ P, ;FAIL IF NO NEW PAGES TO BE HAD
GRBSG1: LDB D,[SEGBYT,,GCST(TT)]
MOVEM D,IMSGLK ;CDR THE FREE SEGMENT LIST
MOVE D,[$XM,,QRANDOM] ;MARK NEW SEGMENT IN ST TABLE
MOVEM D,ST(TT)
SETZM GCST(TT) ;RESET GCST TABLE ENTRY
LSH TT,SEGLOG ;RETURN A POINTER TO THE HEAD OF THE SEGMENT
AOS (P)
POPJ P,
;THIS ROUTINE IS FOR NORMAL ALLOCATION OF SEGMENTS BY THE GC
GCWORRY:SUBI AR2A,(TT) ;ENTRY FOR GARBAGE COLLECTOR
ADDI AR2A,SEGSIZ-1 ;FIGURE OUT HOW MANY NEW SEGMENTS WE NEED
LSH AR2A,-SEGLOG
GRABWORRY:
HRRZ AR1,VMSGFILES
TLO AR1,200000
JUMPE F,.+2 ;ENTRY FOR GCGRAB
SKIPN GCGAGV ;MAYBE WE WANT A PRETTY MESSAGE?
SOJA AR2A,GCWOR2 ;IF NOT, DECR AR2A (SEE BELOW)
STRT 17,[SIXBIT \↑M;ADDING !\]
SOJG AR2A,GCWR0A ;AR2A GETS DECR'ED HERE, TOO!
STRT 17,[SIXBIT \A!\] ;KEEP THE ENGLISH GOOD
JRST GCWR0B
GCWR0A: MOVEI R,$TYO
MOVEI TT,1(AR2A)
PUSH FXP,AR2A
IFE USELESS, MOVE C,@VBASE ;BASE DAMN WELL BETTER BE A FIXNUM
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
POP FXP,AR2A
GCWR0B: STRT 17,[SIXBIT \ NEW !\]
STRT 17,@GSTRT9+NFF(F)
STRT 17,[SIXBIT \ SEGMENT!\]
SKIPE AR2A
STRT 17,[SIXBIT \S!\]
GCWOR2: SKIPE TT,IMSGLK
JRST GCWR2A ;JUMP IF ANY SEGMENTS AVAILABLE
PUSHJ P,ALIMPG ;ELSE MUST GRAB A NEW PAGE
JRST GCWOR7
GCWR2A: LDB D,[SEGBYT,,GCST(TT)]
MOVEM D,IMSGLK ;CDR THE FREE SEGMENT LIST
MOVE D,FSSGLK+NFF(F) ;CONS NEW SEGMENT ONTO LIST
MOVEM TT,FSSGLK+NFF(F) ; OF SEGMENTS FOR THE
HRRZ R,BTBAOB ; PARTICULAR SPACE
HLL R,GCWORS+NFF(F)
LSH D,22-<SEGLOG-5>
GCWR2B: TLNE R,$FS+FX+FL+BN+HNK+DB+CX+DX .SEE GCWR2C
IORI D,(R) ;MAYBE ALLOCATE A BIT BLOCK FOR
IOR D,GCWORG+NFF(F) ; THE NEW SEGMENT FOR USE BY
MOVEM D,GCST(TT) ; GC IN MARKING CELLS
MOVE D,GCWORS+NFF(F) ;UPDATE ST ENTRY FOR THE
MOVEM D,ST(TT) ; NEW SEGMENT
MOVE D,FFS+NFF(F) ;ADD CELLS OF SEGMENT TO
LSH TT,SEGLOG ; THE FREE STORAGE
MOVEM D,(TT) ; LIST FOR THIS SPACE
MOVE D,[GCWORX,,1]
BLT D,LPROG9
HLL TT,GCWORN+NFF(F)
HRR GCWRX1,GCWORN+NFF(F)
HRRI GCWRX2,-1(GCWRX1)
JRST GCWRX1
;GCWR2C GCWR3A GCWR3B GCWR3F GCWOR4 GCWR4Q GCWOR6 GCWOR7
GCWR2C: HRRZM TT,FFS+NFF(F)
TLNN R,$FS+FX+FL+BN+HNK+DB+CX+DX .SEE GCWR2B
JRST GCWR4Q
HRRZ TT,BTBAOB ;DECIDE WHETHER THIS BIT BLOCK
LSH TT,SEGLOG-5 ; LIES IN MAIN BIT BLOCK AREA
MOVEI D,-1(TT)
CAME D,MAINBITBLT
JRST GCWR3A
ADDI D,BTBSIZ ;YES - JUST UPDATE MAIN BLT
MOVEM D,MAINBITBLT ; POINTER FOR CLEARING
JRST GCWR3B ; BIT BLOCKS (SEE GCINBT)
GCWR3A: LSH TT,-SEGLOG ;ELSE AOS COUNT OF BIT BLOCKS
AOS GCST(TT) ; IN CURRENT BIT BLOCK SEGMENT
GCWR3B: MOVE TT,BTBAOB ;AOBJN THE BIT BLOCK
AOBJN TT,GCWOR4 ; ALLOCATION POINTER
SKIPE TT,IMSGLK ;FOO! OUT OF BIT BLOCKS!
JRST GCWR3F
PUSHJ P,ALIMPG ;FOO FOO! NEED NEW PAGE!
JRST GCWFOO
GCWR3F: LDB D,[SEGBYT,,GCST(TT)]
MOVEM D,IMSGLK ;CDR LIST OF FREE SEGMENTS
MOVE D,[$XM,,QRANDOM] ;UPDATE ST AND GCST FOR
MOVEM D,ST(TT) ; NEW BIT BLOCK SEGMENT
MOVEI D,(TT) ;GCST ENTRY IS USED TO
LSH D,5 ; INDICATE HOW MANY
MOVEM D,GCST(TT) ; BLOCKS ARE IN USE
MOVE D,BTSGLK ;CONS NEW SEGMENT ONTO LIST
DPB D,[SEGBYT,,GCST(TT)] ; OF BIT BLOCK SEGMENTS
MOVEM TT,BTSGLK
LSH TT,5 ;CALCULATE NEW BIT BLOCK
HRLI TT,-SEGSIZ/BTBSIZ ; ALLOCATION POINTER
GCWOR4: MOVEM TT,BTBAOB
GCWR4Q: JUMPE F,GCWOR6
MOVEI TT,SEGSIZ ;UPDATE VARIOUS GC PARAMETERS
ADDM TT,NFFS+NFF(F)
ADDB TT,SFSSIZ+NFF(F)
CAMLE TT,XFFS+NFF(F) ;MUST STOP IF OVER MAX
SOJA AR2A,.+2 ;KEEP COUNT ACCURATE
GCWOR6: SOJGE AR2A,GCWOR2 ;ALSO STOP IF WE GOT ALL WE WANT
GCWOR7: JUMPE F,CPOPJ
SKIPN GCGAGV ;MAYBE WANT MORE PRETTY MESSAGE
POPJ P,
SKIPL AR2A
STRT 17,[SIXBIT \↑M; BUT DIDN'T SUCCEED!\]
STRT 17,[SIXBIT \ -- !\]
STRT 17,@GSTRT9+NFF(F)
STRT 17,[SIXBIT \ SPACE NOW !\]
MOVEI R,$TYO
PUSH FXP,AR2A
HRRZ AR1,VMSGFILES
TLO AR1,200000
MOVE TT,SFSSIZ+NFF(F)
IFE USELESS, MOVE C,@VBASE
IFN USELESS,[
HRRZ C,VBASE
CAIE C,QROMAN
SKIPA C,(C)
PUSHJ P,PROMAN
] ;END OF IFN USELESS
PUSHJ P,PRINI9
STRT 17,[SIXBIT \ WORDS!\]
POP FXP,AR2A
POPJ P,
;GCWORG GCWORS GCWFOO GCWORX GCWRX1 GCWRX2 LPROG9 GCWORN
;;; TYPICAL GCST ENTRIES FOR IMPURE SPACES
GCWORG: GCBMRK+GCBCDR+GCBCAR,, ;LIST
GCBMRK,, ;FIXNUM
GCBMRK,, ;FLONUM
DB$ GCBMRK,, ;DOUBLE
CX$ GCBMRK,, ;COMPLEX
DX$ GCBMRK,, ;DUPLEX
BG$ GCBMRK+GCBCDR,, ;BIGNUM
GCBMRK+GCBSYM,, ;SYMBOL
HN$ REPEAT HNKLOG+1, GCBMRK+GCBCDR+GCBCAR+GCBHNK,, ;HUNKS
GCBMRK+GCBSAR,, ;SAR
IFN .-GCWORG-NFF, WARN [WRONG LENGTH TABLE]
0 ;SYMBOL BLOCKS
;;; TYPICAL ST ENTRIES FOR IMPURE SPACES
GCWORS: LS+$FS,,QLIST ;LISP
FX,,QFIXNUM ;FIXNUM
FL,,QFLONUM ;FLONUM
DB$ DB,,QDOUBLE ;DOUBLE
CX$ CX,,QCOMPLEX ;COMPLEX
DX$ DX,,QDUPLEX ;DUPLEX
BG$ BN,,QBIGNUM ;BIGNUM
SY,,QSYMBOL ;SYMBOL
HN$ REPEAT HNKLOG+1, LS+HNK,,QHUNK0+.RPCNT ;HUNKS
SA+$XM,,QARRAY ;SAR
IFN .-GCWORS-NFF, WARN [WRONG LENGTH TABLE]
$XM,,QRANDOM ;SYMBOL BLOCKS
GCWFOO: STRT [SIXBIT \↑M;GLEEP#! OUT OF BIT BLOCKS!\]
JRST GCWOR7
GCWORX: ;EXTEND FREELIST THROUGH NEW SEGMENT
OFFSET 1-.
GCWRX1: HRRZM TT,.(TT) ;OCCUPIES A,B,C,AR1 - MUST SAVE AR2A
GCWRX2: ADDI TT,.
AOBJN TT,GCWRX1
JRST GCWR2C
LPROG9==:.-1
OFFSET 0
.HKILL GCWRX1 GCWRX2
GCWORN: -SEGSIZ+1,,1 ;LIST
-SEGSIZ+1,,1 ;FIXNUM
-SEGSIZ+1,,1 ;FLONUM
DB$ -SEGSIZ/2+1,,2 ;DOUBLE
CX$ -SEGSIZ/2+1,,2 ;COMPLEX
DX$ -SEGSIZ/2+1,,4 ;DUPLEX
BG$ -SEGSIZ+1,,1 ;BIGNUM
-SEGSIZ+1,,1 ;SYMBOL
HN$ REPEAT HNKLOG+1, -SEGSIZ/<1←.RPCNT>+1,,1←.RPCNT ;HUNKS
-SEGSIZ/2+1,,2 ;ARRAY SARS
IFN .-GCWORN-NFF, WARN [WRONG LENGTH TABLE]
-SEGSIZ/2+1,,2 ;SYMBOL BLOCKS
;ALIMPG ALIMP3
SUBTTL IMPURE PAGE GOBBLER
;;; ALLOCATE AN IMPURE PAGE FREE STORAGE USE
ALIMPG:
IFN PAGING,[
MOVE TT,HINXM ;MUST SAVE AR2A AND F FOR GCWORRY
SUBI TT,PAGSIZ
CAMGE TT,BPSH
] ;END OF IFN PAGING
IFE PAGING,[
MOVE TT,HIXM
ADDI TT,PAGSIZ
CAMLE TT,MAXNXM
] ;END OF IFE PAGING
POPJ P, ;NO PAGES LEFT - RETURN WITHOUT SKIP
IFN PAGING,[
MOVEM TT,HINXM ;ELSE UPDATE HINXM
IFN ITS,[
MOVEI R,1(TT)
LSH R,-PAGLOG
.CALL GTSPC8
.LOSE 1000
] ;END OF IFN ITS
IFN D20,[
SETMM 1(TT) ;CREATE THE PAGE
MOVEI 1,1(TT)
LSH 1,-PAGLOG
HRLI 1,.FHSLF
MOVSI 2,(PA%RD\PA%WT\PA%EX)
SPACS
] ;END OF IFN D20
MOVEI D,1(TT) ;COMPUTE A MAGIC BYTE POINTER
LSH D,-PAGLOG
ROT D,-4
ADDI D,(D)
ROT D,-1
TLC D,770000
ADD D,[430200,,PURTBL]
MOVEI C,1
DPB C,D ;UPDATE THE PURTBL
HRRZ R,(P) ;GET THE CALLER'S PC+1
CAIN R,GTCOR4+1 ;DON'T HACK IMSGLK FOR GETCOR
JRST POPJ1
] ;END OF IFN PAGING
IFN <PAGING-1>*D10,[
MOVEM TT,HIXM
CORE TT,
HALT
MOVE TT,HIXM
] ;END OF IFN <PAGING-1>*D10
LSH TT,-SEGLOG
IFN PAGING, ADDI TT,SGS%PG
MOVE C,IMSGLK ;UPDATE ST AND GCST, AND ADD
MOVE AR1,[$XM,,QRANDOM] ; NEW SEGMENTS TO IMSGLK LIST
MOVEI D,SGS%PG
ALIMP3: MOVEM AR1,ST(TT)
SETZM GCST(TT)
DPB C,[SEGBYT,,GCST(TT)]
MOVEI C,(TT)
SOSE D
SOJA TT,ALIMP3
MOVEM TT,IMSGLK ;EXITS WITH LOWEST NEW SEGMENT # IN TT
JRST POPJ1 ;WINNING RETURN SKIPS
;RECLAIM RECL1 RECL2 RECLFW REBIG RECL9 RECL9A
SUBTTL RECLAIM FUNCTION
IFN BIGNUM+USELESS,[
RECLAIM: HRRZS A ;SUBR 2
JUMPE A,CPOPJ ;GC A PARTICULAR SEXP
LOCKI
PUSHJ P,RECL1
MOVEI A,NIL
UNLKPOPJ
RECL1: SKOTT A,LS+PUR
2DIF JRST (TT),RECL9-1,QLIST .SEE STDISP
TLNE TT,HNK+VC+PUR ;DON'T RECLAIM VALUE CELLS!!! (OR HUNKS)
POPJ P, ; - ALSO DON'T RECLAIM PURE WORDS
PUSH P,A ;SAVE ARG
JUMPE B,RECL2 ;B=NIL => RECLAIM ONLY TOP LEVEL OF LIST
HLRZ A,(A) ;RECLAIM CAR
PUSHJ P,RECL1
RECL2: MOVE T,FFS
POP P,FFS
EXCH T,@FFS ;RECLAIM ONE CELL
MOVEI A,(T) ;AND THEN GO AFTER THE CDR
JRST RECL1
RECLFW: JUMPE B,RECL9A ;B=NIL => DON'T RECLAIM FULLWORDS
TLNE TT,$PDLNM ;DON'T RECLAIM PDL LOCATIONS!!!
POPJ P,
2DIF [MOVE T,(TT)]FFS-QLIST ;RECLAIM NUMBER
MOVEM T,(A)
2DIF [MOVEM A,(TT)]FFS-QLIST
POPJ P,
IFN BIGNUM,[
REBIG: MOVE T,FFB ;RECLAIM BIGNUM HEADER
EXCH T,(A)
MOVEM A,FFB
MOVEI A,(T) ;RECLAIM CDR OF BIGNUM
JRST RECL1
] ;END OF IFN BIGNUM
RECL9: JRST RECLFW ;FIXNUM
JRST RECLFW ;FLONUM
DB$ JRST RECLFW ;DOUBLE
CX$ JRST RECLFW ;COMPLEX
DX$ JRST RECLFW ;DUPLEX
BG$ JRST REBIG ;BIGNUM
RECL9A: POPJ P, ;SYMBOL
HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS
POPJ P, ;RANDOM
POPJ P, ;ARRAY
IFN .-RECL9-NTYPES+1, WARN [WRONG LENGTH TABLE]
] ;END OF IFN BIGNUM+USELESS
;MAKVC3 MAKVC4 MAKVC8
IFN PAGING,[
SUBTTL VALUE CELL AND SYMBOL BLOCK HACKERY
;;; ROUTINE TO GET MORE VALUE CELL SPACE.
;;; EXPANDS VALUE CELL SPACE BY GETTING NEXT PAGE IN THE HOLE
;;; LEFT FOR THIS PURPOSE, AND EXTENDING THE VALUE CELL FREELIST.
;;; IF NO PAGES LEFT IN THE HOLE, A LIST CELL IS USED.
;;; MAY CLOBBER ONLY A AND TT.
XCTPRO
MAKVC3: HLLOS NOQUIT
NOPRO
SOSL NFVCP
JRST MAKVC4
PUSHJ P,CZECHI
PUSHJ P,CONS1
SETOM ETVCFLSP
JRST MAKVC1
MAKVC4:
IFN ITS,[
PUSH FXP,R ;MUST SAVE R
MOVE R,EFVCS
LSH R,-PAGLOG
.CALL GTSPC8 ;GET A NEW PAGE
.LOSE 10000
POP FXP,R
] ;END OF IFN ITS
IFN D20,[
PUSHJ FXP,SAV3
MOVE 1,EFVCS
SETMM (1) ;CREATE THE PAGE
LSH 1,-PAGLOG
HRLI 1,.FHSLF
MOVSI 2,(PA%RD\PA%WT\PA%EX)
SPACS
PUSHJ FXP,RST3
] ;END OF IFN D20
MOVE A,EFVCS
MOVEM A,FFVC
LSH A,-SEGLOG
MOVE TT,[LS+VC,,QLIST]
REPEAT SGS%PG, MOVEM TT,ST+.RPCNT(A) ;UPDATE SEGMENT TABLE
MOVSI TT,GCBMRK+GCBVC
REPEAT SGS%PG, MOVEM TT,GCST+.RPCNT(A) ;UPDATE GC SEGMENT TABLE
LSH A,-PAGLOG+SEGLOG ;UPDATE PURTBL
ROT A,-4
ADDI A,(A)
ROT A,-1
TLC A,770000
ADD A,[430200,,PURTBL]
MOVEI TT,1
DPB TT,A
AOS TT,EFVCS ;EXTEND FREELIST THROUGHOUT NEW PAGE
HRLI TT,-PAGSIZ+1
HRRZM TT,-1(TT)
AOBJN TT,.-1
HRRZM TT,EFVCS
MAKVC8: PUSHJ P,CZECHI
JRST MAKVC0
] ;END OF IFN PAGING
;LDPRG9 ARGCL7 MAKVC9 MAKVC5 MAKVC6
;;; SYMBOL BLOCK COPYING ROUTINE - TRIGGERED BY PURE PAGE TRAP, OR EXPLICIT CHECK
;;; B POINTS TO OLD SYMBOL BLOCK
;;; LEAVES POINTER TO NEW SYMBOL BLOCK IN B
;;; CLOBBERS TT, LEAVES POINTER TO VALUE CELL IN A
LDPRG9: TLCA B,LDPARG ;FASLOAD CLOBBERING ARGS PROP
ARGCL7: TLC B,ARGCL3 ;ARGS CLOBBERING ARGS PROP
HRRZ A,(B)
JRST MAKVC6
MAKVC9: TLC B,MAKVCX ;MAKVC CLOBBERING IN VALUE CELL
JRST MAKVC6
MAKVC5: PUSH P,SPSV ;MUST PRESERVE SPSV AS WE CAN COME HERE FROM
; WITHIN A BIND AND AGC DOES BINDING ALSO
PUSHJ P,AGC
POP P,SPSV
BAKPRO
MAKVC6: SKIPN FFY2 ;COME HERE IF HRRM ABOVE CAUSES
JRST MAKVC5 ; A PURE PAGE TRAP - MUST COPY
MOVE TT,@FFY2 ; SYMBOL BLOCK FOR THAT SYMBOL
XCTPRO
EXCH TT,FFY2
NOPRO
HRLI A,SY.ONE\SY.CCN\SY.OTC ;ASSUME COMPILED CODE NEEDS IT FOR OTHER
; THEN CALL UUO'S
MOVEM A,SYMVC(TT) ; (THINK ABOUT THIS SOME MORE)
MOVE A,SYMPNAME(B)
MOVEM A,SYMPNAME(TT)
HRRZ A,(TT)
HRLM TT,@(P)
EXCH TT,B
HLRZ TT,TT
JRST (TT)
;$ALLOC $ALLC6 $ALLC9 $ALLC7 $ALLC8 $ALLC4
SUBTTL ALLOC FUNCTION
$ALLOC: CAIE A,TRUTH ;SUBR 1 - DYNAMIC ALLOC
JRST $ALLC5
SETO F, ;ARG=T => MAKE UP LIST
EXCH F,INHIBIT ;CROCKISH LOCKI - DOESN'T MUNG FXP
MOVNI R,NFF
$ALLC6: PUSH FXP,GFSSIZ+NFF(R) ;SAVE UP VALUABLE DATA
PUSH FXP,XFFS+NFF(R) ;LOCKI KEEPS IT CONSISTENT
PUSH FXP,MFFS+NFF(R)
AOJL R,$ALLC6
IFN PAGING, REPEAT 4, PUSH FXP,XPDL+.RPCNT
MOVEM F,INHIBIT ;EQUALLY CROCKISH UNLOCKI
PUSHJ P,CHECKI
PUSH P,R70
IFN PAGING,[
MOVEI R,4
$ALLC9: POP FXP,TT
SUB TT,C2-1(R)
TLZ TT,-1
JSP T,FIX1A
MOVE B,(P)
PUSHJ P,CONS
MOVEI B,QREGPDL-1(R)
PUSHJ P,XCONS
MOVEM A,(P)
SOJG R,$ALLC9
] ;END OF IFN PAGING
MOVEI R,NFF
$ALLC7: SKIPN SFSSIZ-1(R)
JRST $ALLC8 ;SPACE SIZE IS ZERO - IGNORE IT
POP FXP,TT
PUSHJ P,SSGP2A
PUSHJ P,NCONS
MOVEI B,(A)
POP FXP,TT
JSP T,FIX1A
PUSHJ P,CONS
MOVEI B,(A)
POP FXP,TT
JSP T,FIX1A
PUSHJ P,CONS
MOVE B,(P)
PUSHJ P,CONS
MOVEI B,QLIST-1(R)
CAIN B,QRANDOM
MOVEI B,QARRAY
PUSHJ P,XCONS
MOVEM A,(P)
JRST $ALLC4
$ALLC8: SUB FXP,R70+3 ;FLUSH GARBAGE
$ALLC4: SOJG R,$ALLC7
JRST POPAJ
;$ALLC0 $ALLC5 $ALLC3 $ALLC2 RS.FF RS.VMO RS.SQX RS.BRK RS.SCO RS.WSP RS.DOT RS.MAC RS.SLS RS.RBO RS.SL1 RS.PNT RS.SL9 RS.ALT RS.ARR RS.SGN RS.DIG RS.XLT RS.LTR NWTNE NWTNN RS.FF RS.VMO RS.SQX RS.BRK RS.SCO RS.WSP RS.LP RS.DOT RS.RP RS.MAC RS.SLS RS.RBO RS.SL1 RS.PNT RS.SL9 RS.ALT RS.ARR RS.SGN RS.DIG RS.XLT RS.LTR NWTNE NWTNN RS.CMS RS.SCS RS.OBB RS.WTH RS.SEE
$ALLC0: HRRZ A,(AR2A)
$ALLC5: JUMPE A,TRUE ;DECODE LIST OF PAIRS
HLRZ B,(A) ;ARG IS LIST OF SAME FORM AS
HRRZ AR2A,(A) ; A .LISP. (INIT) COMMENT
HLRZ C,(AR2A)
CAIL B,QREGPDL
CAILE B,QSPECPDL
JRST $ALLC3
MOVEI D,1←-1 ;SSPDLMAX
PUSHJ P,SSGP3$
JRST $ALLC0
$ALLC3: JSP R,SFRET
JRST $ALLC0
JRST $ALLC0
SETZ AR1,
MOVEI F,(C)
SKOTT C,LS
JRST $ALLC2
HRRZ AR1,(C)
HLRZ C,(C)
HLRZ F,(AR1)
SKIPE AR1
SKIPA AR1,(AR1)
SKIPA F,C
HLRZ AR1,(AR1)
$ALLC2: MOVEI D,3←-1 ;SSGCSIZE
PUSHJ P,SSGP3$
MOVEI C,(F)
MOVEI D,5←-1 ;SSGCMAX
PUSHJ P,SSGP3$
MOVEI C,(AR1)
MOVEI D,7←-1 ;SSGCMIN
PUSHJ P,SSGP3$
JRST $ALLC0
PGTOP BIB,[MEMORY MANAGEMENT STUFF]
;;@ END OF GCBIB 231
;;@ READER 196 READ AND RELATED FUNCTIONS
;;; ***** MACLISP ****** READ AND RELATED FUNCTIONS **************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT [RDR]
SUBTTL HIRSUTE READER AND INPUT PACKAGE
IFN NEWRD,[
;;;DEFINE READER-SYNTAX BITS
;;;THESE BITS OCCUPY 2.1-3.8. DO NOT USE 3.9 (SEE TYIPEEK)
RS.FF==004000,, ;FORCE-FEED CHARACTER
RS.VMO==002000,, ;VERTICAL MOTION (LF, FF)
RS.SQX==001000,, ;EXPONENT MARKER, STRING QUOTE
RS.BRK==000400,, ;SPECIAL ACTION NEEDED ON INPUT
RS.SCO==000200,, ;SINGLE-CHARACTER OBJECT
RS.WSP==000100,, ;WHITE SPACE - SPACE, TAB, COMMA
RS.LP ==000040,, ;LEFT PARENTHESIS
RS.DOT==000020,, ;DOTTED-PAIR DOT
RS.RP ==000010,, ;RIGHT PARENTHESIS
RS.MAC==000004,, ;MACRO-CHARACTER (RS.ALT = SPLICING)
RS.SLS==000002,, ;SLASHIFIER
RS.RBO==000001,, ;RUBOUT, FORCEFEED
RS.SL1==400000 ;SLASH IF FIRST IN PNAME
RS.PNT==200000 ;DECIMAL POINT (FOR NUMBERS)
RS.SL9==100000 ;SLASH IF NOT FIRST IN PNAME
RS.ALT==040000 ;CHANGE MEANING OF OTHER BITS
RS.ARR==020000 ;NUMBER MODIFIERS ← AND ↑
RS.SGN==010000 ;NUMBERS SIGNS + AND -
RS.DIG==004000 ;DIGITS 0 THROUGH 9
RS.XLT==002000 ;EXTENDED LETTERS (LIKE :)
RS.LTR==001000 ;REGULAR LETTERS (LIKE X)
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==<RS.!A>←22
TERMIN
NWTNE==:TRNE
NWTNN==:TRNN
DEFINE NWTN ZP,AC,SX
TDN!ZP AC,[RS.!SX]
TERMIN
] ;END IFN NEWRD
IFE NEWRD,[
;;;DEFINE READER-STYNTAX BITS
RS.FF==0
RS.VMO==0
RS.SQX==0
RS.BRK==400000
RS.SCO==200000
RS.WSP==100000
RS.LP==40000
RS.DOT==20000
RS.RP==10000
RS.MAC==4000
RS.SLS==2000
RS.RBO==1000
RS.SL1==400
RS.PNT==200
RS.SL9==100
RS.ALT==40
RS.ARR==20
RS.SGN==10
RS.DIG==4
RS.XLT==2
RS.LTR==1
IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO]
RS%!A==RS.!A
TERMIN
NWTNE==:TLNE
NWTNN==:TLNN
DEFINE NWTN ZP,AC,SX
TLN!ZP AC,RS.!SX
TERMIN
] ;END OF IFE NEWRD
RS.CMS==RS.<BRK+SL1+SL9+MAC> ;CHARACTER-MACRO SYNTAX
RS.SCS==RS.<BRK+SL1+SL9+SCO> ;SINGLE-CHAR-OBJ SYNTAX
;SYNTAX FOR CHARS THAT BEGIN OBJECTS
RS.OBB==RS.<SQX+SCO+LP+MAC+SLS+PNT+SGN+DIG+XLT+LTR>
RS.WTH==RS.<OBB+DOT+RP+ARR> ;PRETTY MUCH, ANY WORTHY CHAR
RS.SEE==RS.<WTH+WSP+RBO+FF> ;ALMOST ANY CHAR THAT YOU REALLY SEE
;$READCH RDCH$ READCH RDCH3 $ASCII RDCH2
SUBTTL READCH AND ASCII FUNCTIONS,
$READCH: JSP D,INCALL
Q$READCH
RDCH$:
READCH: PUSHJ P,TYI
RDCH3: MOVE TT,A
JRST RDCH2
$ASCII: JSP T,FXNV1
RDCH2:
SA$ CAIN TT,203
SA$ JRST READCH
SA$ CAIN TT,315
SA$ MOVEI TT,15
ANDI TT,177
MOVE B,TT
MOVE D,VOBARRAY
ADDI TT,OBTSIZ+1
ROT TT,-1
JUMPL TT,.+3
HLRZ A,@1(D)
JRST .+2
HRRZ A,@1(D)
JUMPN A,CPOPJ
JRST RDCHO
;XINCALL INCAST INCSEO XINCA1 INCALL INCAL4 INCST2 INCST3 INCST4 INCAL5 INCAL1 INCALZ INBIND INBN4 INBN1 INBN9 LINBN9 INCAL2 INCST1 INCAL7 EOFBN0 EOFBIND EOFBN3 EOFBN5 CEOFBN5
SUBTTL NEWIO INPUT FUNCTION ARGS PROCESSOR
;;; JSP D,INCALL
;;; Q<FNNAME>
;;; PROCESSES ARGUMENTS FOR AN INPUT FUNCTION TAKING STANDARD
;;; ARGUMENTS (EOF VALUE AND/OR FILE ARRAY). SAVES F.
;;; JSP D,XINCALL
;;; Q<FNNAME>
;;; IS SIMILAR, BUT INSISTS ON A FIXNUM RESULT (FOR TYI, TYIPEEK),
;;; AND EXPECTS F TO CONTAIN EITHER "FIX1" OR "CPOPJ".
;;; SAVES AR2A (SEE TYIPEEK).
XINCALL:
JUMPN T,XINCA1
PUSH P,F
SFA% JRST 1(D)
IFN SFA,[
INCAST: PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
HRLZI T,AS.SFA ;CHECK FOR AN SFA
TDNN T,ASAR(AR1) ;FOUND AN SFA?
JRST 1(D) ;NOPE, RETURN RIGHT AWAY
HLRZ TT,(D) ;GET POINTER TO OP BIT
MOVE T,(TT) ;GET THE ACTUAL BIT
MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS
TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION?
JRST 1(D) ;NO, RETURN AS NORMAL
INCSEO: MOVEI C,INCSEO ;GIVE IT SOMETHING UNIQUE
PUSH FXP,D ;MAY NEED TO RETURN IF OVER-RUBOUT
PUSH P,AR1 ;REMEMBER THE SFA
PUSHJ P,ISTCAL ;YES, PROCESS IT
POP FXP,D
POP P,AR1
CAIE A,INCSEO ;DID THE SFA RETURN EOF?
POPJ P, ;NO, RETURN
PUSHJ P,EOF ;HANDLE EOF
JRST INCAST ;IF RETURN THEN PROCEED AROUND AGAIN
] ;END IFN SFA
XINCA1: TLOA D,1 ;MUST HAVE FIXNUM RESULT
INCALL:
SFA$ JUMPE T,INCAST ;ZERO ARGS
SFA% JUMPE T,1(D)
AOJL T,INCAL2
SETZ AR1,
EXCH AR1,(P) ;DEFAULT NIL FOR EOF VALUE
INCAL4: JUMPE AR1,EOFBN0 ;NOT IF NIL
JSP TT,XFOSP ;FILE OR SFA?
JRST EOFBN0 ;NOT IF T, OR IF NOT FILE
IFN SFA,[
JRST INCAL5
INCST2: HLRZ TT,(D) ;GET POINTER TO OP BIT
MOVE T,(TT) ;GET THE ACTUAL BIT
MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS
TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION?
JRST INCALZ ;NO, HANDLE NORMALLY: LOWER LEVEL WILL TRAP
POP P,C ;GET EOF VALUE
TLNN D,1 ;EXPECTING A FIXNUM RESULT?
JRST ISTCAL ;NOPE, CALL THE STREAM AND GO ON
PUSH P,C ;REMEMBER EOF VALUE AGAIN
INCST3: MOVEI C,INCST3 ;NEW EOF VALUE, SOMETHING UNIQUE
PUSHJ P,ISTCAL ;CALL THE SFA
POP P,C ;RESTORE EOF VALUE
CAIN A,INCST3 ;DID THE SFA RETURN EOF?
JRST INCST4 ;YES, HANDLE IT
JSP T,FXNV1 ;ELSE THE VALUE RETURNED MUST BE A FIXNUM
POPJ P,
INCST4: SKIPN A,C ;FOR A NULL EOF VALUE, SNEAKILY
MOVEI A,IN0-1 ; SLIP IN -1
JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED
POPJ P, ; MUST BE A FIXNUM
] ;END IFN SFA
INCAL5: MOVE A,TTSAR(AR1) ;GET ARRAY TYPE BITS
TLNN A,TTS.IO ;MUST BE INPUT
JRST INCAL1
EXCH A,AR1
PUSHJ P,[IOL [NOT AN INPUT FILESPEC!]]
EXCH A,AR1
JRST INCAL4
INCAL1: TLNN A,TTS.TY ;IF TTY ALLOW BINARY MODE
TLNN A,TTS.BN ;MUST NOT BE BINARY FILE
JRST INCALZ
EXCH A,AR1
PUSHJ P,[IOL [NOT ASCII FILE!]]
EXCH A,AR1
JRST INCAL4
INCALZ: POP P,A ;RESTORE EOF VALUE
INBIND: SKIPE B,AR1
JRST INBN4
PUSHJ P,INFGET ;GETS VINFILE IN AR1
MOVEI B,(AR1)
INBN4: CAIN B,TRUTH
TDZA C,C
SKIPA C,[TRUTH]
HRRZ AR1,V%TYI
; PUSHJ P,ATIFOK
; UNLOCKI
MOVSI T,-LINBN9 ;OPEN-CODING OF SPECBIND
MOVEM SP,SPSV
INBN1: HRRZ TT,INBN9(T)
HRRZ R,(TT)
HRLI R,(TT)
PUSH SP,R
HLRZ R,INBN9(T)
TRNN R,777760
HRRZ R,(R)
MOVEM R,(TT)
AOBJN T,INBN1
JSP T,SPECX ;END OF SPECBIND
PUSH P,CUNBIND
JRST EOFBIND
INBN9: C,,TAPRED ;TABLE OF VALUE CELLS FOR INBIND
B,,VINFILE ; EACH ENTRY IS OF FORM:
NIL,,VINSTACK ; <NEW VALUE>,,<VALUE CELL>
$DEVICE,,TYIMAN ; IF NEW VALUE IS AN AC, THEN
UNTYI,,UNTYIMAN ; THE AC CONTAINS THE REAL
;; UNRD,,UNREADMAN ; NEW VALUE.
;; READP,,READPMAN
LINBN9==.-INBN9
INCAL2: AOJL T,INCAL7
POP P,A ;TWO ARGS
POP P,AR1
JUMPE AR1,INBIND
CAIN AR1,TRUTH
JRST INBIND
PUSH P,A ;SAVE EOF VALUE
JSP TT,XFOSP
SFA% SKIPA
SFA% JRST INCAL5
IFN SFA,[
JRST INCST1
JRST INCAL5
JRST INCST2
INCST1: ] ;END IFN SFA
EXCH A,AR1 ;OTHER MUST BE FILE ARRAY
MOVEM A,(P) ;STORE NEW EOF VALUE
JRST INCAL4 ;MAKE SURE OTHER IS CORRECT
INCAL7: HRRZ D,(D) ;MORE THAN TWO ARGS: FOOEY.
JRST S2WNAL
EOFBN0: POPI P,1 ;GET EOF VALUE OFF STACK
MOVEI A,(AR1)
EOFBIND:
TLNN D,1 ;BIND FOR INPUT EOF TRAP
JRST EOFBN3
PUSH P,F ;FOR NUMERICAL INPUT FN, FIX1 OR CPOPJ
TLO A,400000
EOFBN3: PUSH P,A
PUSH P,CEOFBN5
JSP T,ERSTP ;SET UP A FRAME
MOVEM P,EOFRTN ;THIS IS AN EOF FRAME
SETZM BFPRDP .SEE EOF2
SFA% PUSHJ P,1(D) ;RUN CALLING FUNCTION
SFA$ MOVEI C,(A) ;THIS IS THE EOF VALUE FOR SFAS
SFA$ PUSHJ P,INCAST ;HANDLE AN SFA, ELSE RUN THE CALLER
MOVSI D,-LEP1+1(P) ;RESTORE FRAME STUFF
HRRI D,ERRTN
BLT D,ERRTN+LEP1-1
SUB P,[LERSTP+2,,LERSTP+2] ;FLUSH FRAME
POPJ P, ;RETURN (RESULT IN A OR TT)
EOFBN5: POP P,A ;COME HERE ON EOF
TLZN A,400000
CEOFBN5:
POPJ P,EOFBN5
SKIPN A ;FOR A NULL EOF VALUE, SNEAKILY
SKIPA TT,XC-1 ; SLIP IN A -1 INSTEAD
JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED
POPJ P, ; MUST BE A FIXNUM
;EOF EOF2 EOF8 EOF1 EOF7 EOF4 EOF9 EOF5 EOFZ
SUBTTL NEWIO END-OF-FILE HANDLING
;;; HANDLE EOF ON STANDARD FILE ARRAY IN AR1.
EOF: PUSHJ FXP,SAV5
HRRZ T,BFPRDP ;CHECK WHETHER IN READ
JUMPN T,EOFE
EOF2:
SFA$ MOVSI TT,AS.SFA
SFA$ TDNE TT,ASAR(AR1) ;DID AN SFA GET EOF?
SFA$ JRST EOFZ ;YES, NEVER ANY EOFFN
MOVEI TT,FI.EOF
HRRZ B,@TTSAR(AR1)
JUMPE B,EOF5
EXCH B,AR1
SKIPE A,EOFRTN
HRRZ A,-LERSTP-1(A) .SEE EOFBIND
EXCH A,B
CALLF 2,(AR1)
JUMPN A,EOF4
EOF8: SKIPE TAPRED ;READING FROM INFILE?
PUSHJ P,INPOP ;YES, POP THE INPUT STACK
PUSHJ P,EOF7
EOF1: JSP R,PDLA2-5
POPJ P,
EOF7: HRRZ A,-2(P) ;SAVED AR1
MOVE TT,TTSAR(A)
TLNN TT,TTS<TY> ;DON'T CLOSE TTY INPUT,
PUSHJ P,ICLOSE ; FOR THAT WAS MERELY OVER-RUBOUT
POPJ P,
EOF4: CAIN A,TRUTH
JRST EOF1
SKIPN T,EOFRTN
JRST EOF8
HRRM A,-LERSTP-1(T) .SEE EOFBIND
EOF9: MOVE P,EOFRTN .SEE TYPK9
JRST ERR1
EOF5: PUSHJ P,EOF7
EOFZ: SKIPE TAPRED ;NO EOF FUNCTION. READING FROM INFILE?
PUSHJ P,INPOP ;YES, POP THE STACK
SKIPN EOFRTN
JRST EOF1
JRST EOF9
;INPU0 INPUSH INPU1 INPU12 INPU2 INPU3 INPOP INPU5 INPU6 INPU7 INPU8
SUBTTL NEWIO INPUSH FUNCTION
;;; HAIRY INPUSH FUNCTION. PUSHES FILE ONTO INSTACK,
;;; OR MAYBE PUSHES INFILE, OR MAYBE POPS.
;;; INPOP POPS INSTACK INTO INFILE ONCE.
INPU0: WTA [BAD ARG - INPUSH!]
INPUSH: CAIN A,TRUTH ;SUBR 1
HRRZ A,V%TYI
JSP TT,AFILEP
JRST INPU2
PUSHJ P,ATIFOK
UNLOCKI
EXCH A,VINFILE
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM B,VINSTACK
INPU1: SKIPN A,VINFILE
JRST INPU12
CAIN A,TRUTH
SETZM TAPRED
POPJ P,
INPU12: PUSHJ P,INFLUZ
JRST INPU1
INPU2: SKOTT A,FX
JRST INPU0
SKIPN TT,(A)
JRST INPU1
JUMPL TT,INPU5
INPU3: HRRZ A,VINFILE ;AN INPUSH LOOP
HRRZ B,VINSTACK
PUSHJ P,CONS
MOVEM A,VINSTACK
SOJG TT,INPU3
JRST INPU1
INPOP: MOVNI TT,1
PUSH P,A ;MUST SAVE A (E.G., SEE LOAD)
PUSH P,CPOPAJ
INPU5: PUSH FXP,TT
INPU6: SKIPN A,VINSTACK
JRST INPU8
HLRZ AR1,(A)
; PUSHJ P,ATIFOK
; UNLOCKI
HLRZ AR1,(A)
MOVEM AR1,VINFILE
HRRZ A,(A)
MOVEM A,VINSTACK
AOSGE (FXP)
JRST INPU6
INPU7: SUB FXP,R70+1
JRST INPU1
INPU8: MOVEI A,TRUTH
MOVEM A,VINFILE
JRST INPU7
;TYI$ %TYI TYI UNTYI UNTYI3 SUNTYI
SUBTTL TYI FUNCTION AND RELATED ROUTINES
TYI$: SKIPA F,CFIX1 ;SUBR (NIL . 0) NCALLABLE
MOVEI F,CPOPJ
PUSH P,F
JRST TYI
%TYI: SKIPA F,CFIX1 ;LSUBR (0 . 2) NCALLABLE
MOVEI F,CPOPJ
JSP D,XINCALL
SFA% Q%TYI
SFA$ [SO.TYI,,],,Q%TYI
TYI: MOVEI A,Q%TYI
PUSH FXP,BFPRDP
HRLZM A,BFPRDP
PUSHJ P,@TYIMAN
POP FXP,BFPRDP
MOVEI A,(TT) ;BARF
POPJ P,
;;; MAIN UNTYI ROUTINE
;;; ACCEPTS CHARACTER IN A AND INPUT FILE IN VINFILE.
;;; STICKS CHARACTER BACK INTO CHARACTER BUFFER.
;;; CLOBBERS A,B,AR1,T,TT,D. MUST SAVE C (SEE READ).
UNTYI: PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
IFN SFA,[
MOVSI TT,AS.SFA ;HANDLE DIFFERENTLY IF AN SFA
TDNE TT,ASAR(AR1) ;SKIP IF NOT AN SFA
JRST SUNTYI ;SFA UNTYI
] ;END IFN SFA
MOVEI D,300000(A) ;USE 200000 BIT (IN CASE OF ↑@)
MOVEI TT,FI.BBC ;THE 100000 BIT IS A CROCK FOR PRATT
;THAT MEANS DO NOT PUT CHAR OUT ON ECHOFILES
HLRZ T,@TTSAR(AR1) ;GET SINGLE BUFFERED CHAR
JUMPE T,UNTYI3 ;THERE IS NONE - THIS IS EASY
HRRZ B,@TTSAR(AR1) ;FOOEY - WE MUST CONS THE
MOVEI TT,-200000(T) ; OLD BUFFERED BACK CHAR
JSP T,FXCONS ; INTO THE LIST TO LEAVE ROOM
PUSHJ P,CONS ; FOR THE NEW ONE
MOVEI TT,FI.BBC
HRRZM A,@TTSAR(AR1)
UNTYI3: HRLM D,@TTSAR(AR1) ;BUFFER BACK NEW CHAR
POPJ P,
IFN SFA,[
SUNTYI: PUSH P,C ;CANNOT BASH C
MOVEI TT,(A) ;CHARACTER INTO TT
JSP T,FXCONS ;GENERATE A LISP FIXNUM
MOVSI T,SO.UNT ;UNTYI OPERATION
MOVEI C,(A) ;ARGUMENT INTO C (CHARACTER TO UNTYI)
PUSHJ P,ISTCAL ;GO TO THE SFA CALLER
POP P,C
POPJ P,
] ;END IFN SFA
;$PEEK $DEVICE $DEV0 $DEVP1 $DEVP2 $DEVPE $DEV0Z $DEV0B $DEV1 $DVLUZ $DEV2 $DEV2B $DEV2D $DEV2E $DEV2P $DEV4Q $DEV4 TYIXCT $DEV4B TYIXCT TYIXCT $DEVS4 $DEV4S $DEV4U $DEV4Z $DEV4A $DEV4D $DEV4H $DEV4H TYICAL $DEV4K $DEV4M $DEV5F $DEV5 $DEV6 $DEV6A $DEV6B $DEV7 $DEV5K TYICA1 $DEV5M $DEVER INFGT0 INFGET INFLZZ INFLUZ
;;; MAIN INPUT FILE ARRAY HANDLER
;;; FILE ARRAY IN VINFILE.
;;; SAVES A,B,C,AR2A; CLOBBERS AR1.
;;; RETURNS CHARACTER IN TT.
;;; ACCUMULATOR D IS ZERO FOR PEEKING, ELSE 1.
$PEEK: TDZA D,D
$DEVICE: MOVEI D,1
$DEV0: PUSHJ P,INFGET ;GETS VINFILE IN AR1
SKIPE TAPRED
CAIN AR1,TRUTH
HRRZ AR1,V%TYI
IFN SFA,[
MOVSI T,AS.SFA ;BREAK AWAY HERE IF SFA
TDNN T,ASAR(AR1) ;SFA?
JRST $DEV0Z ;NOPE, CONTINUE AS USUAL
PUSH FXP,D ;SAVE D OVER CALL
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,AR1
PUSH P,AR2A
SETZ C, ;NIL AS OP DEPENDENT ARGS
JUMPE D,$DEVPE ;PEEKING, MIGHT HANDLE THE SFA DIFFERENTLY
HRLZI T,SO.TYI ;WE ARE DOING A TYI
$DEVP1: PUSHJ P,ISTCAL ;INTERNAL SFA CALL, SFA IN AR1
$DEVP2: POP P,AR2A
POP P,AR1
POP P,C
POP P,B
POP FXP,D
SKIPE A ;ALLOW NIL
JSP T,FXNV1 ;INSURE FIXNUM AND GET INTO TT
JUMPN A,POPAJ ;IF NON-NIL THEN GOT SOMETHING, SO RETURN IT
MOVNI TT,1
JUMPE D,POPAJ ;ONLY PEEKING, SO MERELY RETURN -1
PUSHJ P,EOF ;SIGNAL EOF
POP P,A
JRST $DEVICE ;RETRY IF WE SURVIVE
$DEVPE: MOVEI TT,SR.WOM ;CHECK THE WHICH-OPERATIONS MASK FOR TYIPEEK
MOVSI T,SO.TIP
TDNE T,@TTSAR(A) ;CAN IT DO IT?
JRST $DEVP1 ;YES, DO IT DIRECTLY
MOVSI T,SO.TYI ;ELSE DO IT AS TYI/UNTYI
MOVEI AR1,(A) ;STREAM IN AR1 FOR ISTCAL
PUSHJ P,ISTCAL ;DO THE TYI
JUMPE A,$DEVP2 ;HIT EOF
PUSH P,A ;REMEMBER THE CHAR WE WERE HANDED
MOVSI T,SO.UNT ;NOW UNTYI THE CHARACTER
MOVEI C,(A) ;THE ARG IS THE CHARACTER
MOVE A,-2(P) ;GET THE SFA AS FIRST ARG
PUSHJ P,ISTCAL ;DO THE UNTYI
POP P,A ;FUDGE THE CHARACTER AS THE RETURNED VALUE
JRST $DEVP2
$DEV0Z: ] ;END IFN SFA
MOVSI T,TTS.CL
TDNE T,TTSAR(AR1)
JRST $DVLUZ ;INPUT (FILE) CLOSED LOSSAGE!
.5LOCKI
MOVE T,TTSAR(AR1)
; SKIPE FI.BBF(T) ;BUFFERED-BACK FORMS NOT IMPLEMENTED YET
; JRST $DEVER
SKIPN TT,FI.BBC(T)
JRST $DEV2
TLZN TT,200000
JRST $DEV1
HLRZ TT,TT
SKIPE D
HRRZS FI.BBC(T)
$DEV0B: TRZN TT,100000 ;100000 MEANS DON'T OUTPUT TO ECHOFILES
JRST $DEV7
UNLKPOPJ .SEE UNTYI
$DEV1: MOVS TT,(TT)
SKIPE D
HLRZM TT,FI.BBC(T)
MOVE TT,(TT)
JRST $DEV0B
$DVLUZ: PUSHJ P,INFLZZ
JRST $DEV0
$DEV2: HLRZ R,BFPRDP
TLNN T,TTS<TY> ;IF THIS ISN'T A TTY,
JRST $DEV4 ; THEN FORGET CLEVER HACKS
CAIN R,Q%TYI ;IF THIS IS TYI, THEN
JRST $DEV4H ; PULL CLEVER ACTIVATION HACK
JUMPE R,$DEV4 ;NIL MEANS NO CLEVERNESS AT ALL
HRRZ R,TI.BFN(T) ;FORGET PRE-SCAN IF THERE IS
JUMPE R,$DEV4Q ; NO PRE-SCAN FUNCTION
$DEV2B: HRLM D,(P)
PUSHJ FXP,SAV5 ;OTHERWISE SAVE THE WORLD
MOVEI A,(AR1) ;INVOKE THE PRE-SCAN FUNCTION
HLRZ B,BFPRDP ; WITH THREE ARGUMENTS:
MOVEI AR2A,(R) ; (1) THE FILE ARRAY
UNLOCKI ; (2) THE FUNCTION TO BUFFER FOR
LDB T,[002100,,BFPRDP] ; (3) IF (2) IS 'READ, THE
PUSH FXP,T ; NUMBER OF HANGING OPEN
MOVEI C,(FXP) ; PARENTHESES
CALLF 3,(AR2A)
SUB FXP,R70+1
HRRZ AR1,-1(P)
JUMPN A,$DEV2D ;NIL MEANS OVER-RUBOUT, ERGO EOF
JSP R,PDLA2-5
JRST $DEV4D
$DEV2D: MOVEI C,(A)
SKIPE V.RSET
CAIN R,QTTYBUF ;DON'T NEED TO CHECK RESULT IF
JRST $DEV2P ; IT WAS OUR OLD FRIEND TTYBUF
MOVEI B,(C)
$DEV2E: JUMPE B,$DEV2P
HLRZ A,(B)
JSP F,TYOARG
HRRZ B,(B)
JRST $DEV2E
$DEV2P: HRRZ AR1,-1(P)
MOVEI TT,FI.BBC
HRRZM C,@TTSAR(AR1)
JSP R,PDLA2-5
HLRZ D,(P)
JRST $DEV0
$DEV4Q: MOVE F,F.MODE(T)
TLNN F,FBT<FU> ;IF TTY DOESN'T HAVE 12.-BIT
JRST $DEV4 ; CHARS, THEN WE ARE WINNING
UNLOCKI
PUSHJ P,INFLUZ ;OTHERWISE WE LOSE
JRST $DEV0
20$ $DEV4H:
$DEV4: SKIPL F,F.MODE(T) .SEE FBT.CM
JRST $DEV5
IFN ITS,[
MOVE R,F.CHAN(T)
LSH R,27
IOR R,[.IOT 0,TT]
SPECPRO INTTYX
TYIXCT: XCT R ;INPUT CHARACTER
NOPRO
$DEV4B: JUMPL TT,$DEV4A ;JUMP ON EOF
AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG)
JRST $DEV6
] ;END OF IFN ITS
IFN D20,[
PUSHJ FXP,SAV3
HRRZ 1,F.JFN(T)
MOVE 2,[444400,,TT]
MOVNI 3,1
SPECPRO INTTYX
TYIXCT: SIN ;INPUT CHARACTER
NOPRO
MOVE R,3
PUSHJ FXP,RST3
JUMPN R,$DEV4A ;JUMP ON EOF
AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG)
SKIPN TENEXP
JRST $DEV6
TRNN F,10 ;SAIL DOES THIS TOO?
TLNE F,FBT.FU ;I DON'T UNDERSTAND THIS
JRST $DEV6
CAIN TT,37 ;TENEX ↑← IS CR, BARF
MOVEI TT,↑M ;↑← -> CR
JRST $DEV6
] ;END OF IFN D20
IFN D10,[
SA$ $DEV4C: ;SAIL WANT'S LINMOD CHECK EVEN FOR TYI
MOVE R,[INCHWL TT]
TLNN F,FBT.LN
SA% $DEV4C:
MOVE R,[INCHRW TT]
SPECPRO INTTYX
TYIXCT: XCT R
NOPRO
IFN SAIL,[
TRNE F,10 ;FORGET THIS HACK FOR IMAGE MODE
JRST $DEV6
MOVEI R,(TT) ;CANONICALIZE ASCII CODES
TLNE F,FBT.FU ;I DON'T UNDERSTAND THIS
JRST $DEVS4 ;BUT CONVERT IN NON-FULL MODE
CAIN R,32 ;TILDE: 32 => 176
HRROI R,176
CAIN R,176 ;RIGHT BRACE: 176 => 175
HRROI R,175
CAIN R,175 ;ALTMODE: 175 => 33
HRROI R,33
CAIN R,33 ;NOT EQUALS: 33 => 32
HRROI R,32
$DEVS4: ANDI TT,600
IORI TT,(R)
TLNE F,FBT.FU ;IF FULL CHARACTER SET (BUCKY BITS),
JRST $DEV4S ; DON'T DO ANY CONVERSIONS
CAIGE TT,40 ;A CONTROL CHARACTER?
ADDI TT,%TXCTL+"@ ;YES, CONVERT TO EXTENDED ASCII FORMAT
$DEV4S: TRNN TT,%TXCTL+%TXMTA ;USE PRESENCE OF CONTROL BIT TO CHECK FOR INT
JRST $DEV6
; PUSH FXP,TT ;SAVE THE ACTUAL CHARACTER
; SUBI TT,%TXCTL+"@
; CAIL TT,"a-"@ ;IS IT A LOWER CASE LETTER?
; CAILE TT,"z-"@
; SKIPA ;NOPE, LEAVE ALONE
; SUBI TT,"a-"@-1 ;ELSE CONVERT TO REAL CONTROL CHARACTER
; SKIPL TT
; CAILE TT,"← ;IS IT A REAL "CONTROL" CHARACTER?
; JRST $DEV4V ;NO, FIXUP THE WORLD AND PROCEED
] ;END OF IFN SAIL
SA% CAIL TT,40 ;CONTROL CHARS CAUSE AN INTERRUPT WHEN READ
SA% JRST $DEV6
$DEV4U: HRLM D,(P)
MOVEI D,(TT) ;ONLY INTERRUPT IF INT FUNCTION EXISTS
ROT D,-1 ;CLEVER ARRAY ACCESS AS PER TTYICH
ADDI D,FB.BUF(T)
PUSH FXP,R
HLRZ R,(D)
SKIPGE D
HRRZ R,(D)
JUMPE R,$DEV4Z
MOVEI D,400000(TT)
HRLI D,(AR1) ;THERE IS NO OBVIOUS NEED FOR THIS NOW
PUSHJ P,UCHINT ;GIVE USER INTERRUPT FOR TTY INT CHAR
$DEV4Z: POP FXP,R
HLRZ D,(P)
;IFN SAIL,[
;$DEV4V: POP FXP,TT ;RESTORE THE CONTROL CHARACTER
;] ;END IFN SAIL
JRST $DEV6
] ;END OF IFN D10
$DEV4A: UNLOCKI ;COME HERE ON EOF
$DEV4D: MOVNI TT,1
JUMPE D,CPOPJ ;ONLY PEEKING, SO MERELY RETURN -1
PUSHJ P,EOF ;SIGNAL EOF
JRST $DEVICE ;RETRY IF WE SURVIVE
;;; A TRICKY HACK TO BE CLEVER ABOUT IMMEDIATE ACTIVATION
;;; WHEN TYI (OR READCH, OR WHATEVER) IS INVOLVED.
IFN D10,[
$DEV4H: SKIPL F,F.MODE(T) ;MUST BE THE TTY FOR THIS TO WORK
JRST $DEV5
JRST $DEV4C ;IGNORE LINE MODE, AND USE CHARACTER INPUT UUO
] ;END OF IFN D10
IFN ITS,[
$DEV4H: SKIPL F,F.MODE(T)
JRST $DEV5 ;BUFFERED TTY INPUT??? OH WELL.
SPECPRO INTTYX
TYICAL: .CALL $DEV4M ;GOBBLE CHAR, EVEN IF NOT ACTIVATED
NOPRO
.LOSE 1400
MOVE TT,TTSAR(AR1)
SKIPN R,FT.CNS(TT)
JRST $DEV4K ;DONE IF NO ASSOCIATED OUTPUT TTY
HRLM D,(P)
MOVE TT,TTSAR(R) ;UPDATE CHARPOS AND LINENUM FROM CURSOR
PUSH FXP,T
PUSHJ FXP,CLRO4 ; POSITION OF ASSOCIATED OUTPUT TTY
POP FXP,T
HLRZ D,(P)
MOVE TT,TTSAR(AR1)
$DEV4K: EXCH T,TT
JRST $DEV4B
$DEV4M: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
5000,,%TIACT ;READ CHARACTER IMMEDIATELY EVEN IF NOT ACTIVATOR
,,F.CHAN(T) ;CHANNEL #
402000,,T ;SINGLE CHAR RETURNED HERE (T, NOT TT!)
] ;END OF IFN ITS
$DEV5F: PUSHJ P,$DEV5K
JRST $DEV4A
$DEV5:
10$ HRRZ TT,FB.HED(T)
10$ SOSGE 2(TT)
10% SOSGE FB.CNT(T) ;GOBBLE NEXT INPUT CHAR
JRST $DEV5F ;MAY NEED TO GET NEW BUFFER
10$ ILDB TT,1(TT)
10% ILDB TT,FB.BP(T)
10$ TLNN T,TTS.IM ;IN IMAGE MODE, WHAT YOU SEES IS WHAT YOU GETS
10$ JUMPE TT,$DEV5 ;IN ASCII MODE, A NULL IS LITTERA NON GRATA
$DEV6: JUMPN D,$DEV6B
MOVEI D,(TT)
ANDI D,177+%TXCTL ;? THIS MAY SCREW CONTROL CHARS ON SAIL
TRZN D,%TXCTL
JRST $DEV6A
CAIE D,177
TRZ D,140
$DEV6A: TRO D,200000
HRLM D,FI.BBC(T)
SETZ D,
$DEV6B: CAIN TT,↑J
AOS AT.LNN(T)
CAIE TT,↑L
JRST $DEV7
SETZM AT.LNN(T)
AOS AT.PGN(T)
$DEV7: SKIPE AR1,VECHOFILES ;SKIP UNLESS ECHO FILES
SKIPN D ;DON'T ECHO PEEKED-AT CHARS
UNLKPOPJ
HRLI AR1,200000 ;LIST OF FILES, NO TTY
HRLM TT,AR2A
PUSH P,AR2A
JSP T,GTRDTB ;GET READTABLE
LDB TT,[220700,,(P)] ;WATCHIT! CHAR COULD BE 12. BITS
PUSHJ P,TYO6 ;PUSH CHAR INTO ALL ECHO FILES
HLRZ TT,(P)
POP P,AR2A
UNLKPOPJ
;;; INPUT BUFFER FILL ROUTINE. EXPECTS TTSAR IN T.
;;; SKIPS *UNLESS* NO CHARACTERS READ DUE TO EOF.
;;; SAVES D AND F.
.SEE FPOS5
$DEV5K: PUSH FXP,D
MOVE D,FB.BVC(T) ;GET NUMBER OF VALID BYTES
ADDM D,F.FPOS(T) ;STEP CURRENT FILE POSITION BY THAT AMOUNT
SETZM FB.BVC(T)
IFN ITS,[
EXCH T,TT
MOVE D,FB.BFL(TT) ;BYTE COUNT
MOVE T,FB.IBP(TT) ;BYTE POINTER
TYICA1: .CALL SIOT
.LOSE 1400
EXCH T,TT
SUB D,FB.BFL(T) ;NEGATIVE OF NUMBERS OF BYTES READ
MOVNM D,FB.CNT(T)
MOVNM D,FB.BVC(T)
JUMPE D,POPXDJ ;JUMP OUT ON EOF
] ;END OF IFN ITS
IFN D10,[
MOVE TT,F.CHAN(T)
LSH TT,27
TLO TT,(IN 0,)
XCT TT ;READ A NEW BUFFERFUL
JRST $DEV5M ;SUCCESS!
XOR TT,[<STATO 0,IO.EOF>#<IN 0,>]
XCT TT
HALT ;? LOSEY LOSEY
SA$ MOVE D,FB.HED(T)
SA$ MOVE TT,2(D)
SA$ MOVEM TT,FB.BVC(T)
SA$ SKIPG TT
JRST POPXDJ
$DEV5M: MOVE D,FB.HED(T)
MOVE TT,2(D) ;NUMBER OF VALID BYTES
MOVEM TT,FB.BVC(T)
] ;END OF IFN D10
IFN D20,[
PUSHJ FXP,SAV3 ;PRESERVE LOW THREE AC'S
HRRZ 1,F.JFN(T)
MOVE 2,FB.IBP(T)
MOVN 3,FB.BFL(T)
SIN ;READ A BUFFERFUL
ADD 3,FB.BFL(T)
MOVEM 3,FB.CNT(T) ;STORE COUNT OF BYTES READ IN FILE OBJECT
MOVEM 3,FB.BVC(T)
MOVE D,3
PUSHJ FXP,RST3
JUMPE D,POPXDJ ;NO BYTES READ => EOF
] ;END OF IFN D20
10% MOVE TT,FB.IBP(T)
10% MOVEM TT,FB.BP(T) ;INITIALIZE BUFFER POINTER
POP FXP,D
JRST POPJ1 ;SKIP RETURN ON SUCCESS
$DEVER: UNLOCKI
SETO TT,
JUMPE D,CPOPJ
PUSH P,CPOPNVJ
MOVEI A,(AR1)
PUSHJ P,NCONS
MOVEI B,Q%TYI
PUSHJ P,XCONS
IOL [CAN'T TYI - FORM(S) PENDING!]
INFGT0: PUSHJ P,INFLUZ
INFGET: SKIPN AR1,VINFILE ;GET VINFILE IN AR1
JRST INFGT0
POPJ P,
INFLZZ: SKIPA T,[[SIXBIT \INFILE CLOSED!\]]
INFLUZ: MOVEI T,[SIXBIT \BAD VALUE FOR INFILE!\]
PUSH P,A
MOVEI A,TRUTH ;INFILE IS A LOSER!
EXCH A,VINFILE
PUSH P,CPOPAJ
%FAC (T)
;BYTEAC MKNR6C MKR6DB
SUBTTL READLIST, IMPLODE, MAKNAM
BYTEAC==TT
MKNR6C: MOVEM T,MKNCH
JSP TT,IRDA
SKIPA
MKR6DB: IDPB BYTEAC,C
PUSHJ P,@MKNCH
JRST RDAEND
SOJGE D,MKR6DB
PUSH FXP,BYTEAC
PUSHJ FXP,RDA4
JSP TT,IRDA1
POP FXP,BYTEAC
SOJA D,MKR6DB
;READLIST RDLPEK RDLTYI RDLTY1 RDLTY3 RDLTY9 RDLTY2 RDLPK1 RDLUNTYI READ6C R6C1
READLIST:
JUMPE A,RDL12
MOVEI B,RDLTYI
MOVEI C,RDLUNTYI
JSP T,SPECBIND
0 A,RDLARG
0 B,TYIMAN
0 C,UNTYIMAN
MOVEI A,RDIN
PUSHJ P,READ0A
SKIPE T,RDLARG ;REALLY OUGHT TO ALLOW
CAIN T,-1 ; A TRAILING SPACE
JRST UNBIND
LERR EMS1 ;TOO MANY CHARS
;;; READLIST PEEK AND TYI ROUTINES. (CF. $DEVICE).
;;; SAVES A,B,C,AR2A; CLOBBERS AR1. RETURNS CHARACTER IN TT.
RDLPEK: JRST RDLPK1 ;RDLTYI-1 IS FOR PEEKING (SEE TYIPEEK)
RDLTYI: PUSH P,A
SKIPN A,RDLARG
JRST RDLTY2
CAIN A,-1
LERR EMS3 ;TOO FEW CHARS
HRRZ AR1,(A)
MOVEM AR1,RDLARG
RDLTY1: HLRZ A,(A)
RDLTY3: JSP T,CHNV1
JRST POPAJ
RDLTY9: SIXBIT \NOT ASCII CHAR!\
RDLTY2: HLLOS RDLARG
MOVEI TT,203 ;PSEUDO-SPACE
JRST POPAJ
RDLPK1: SKIPE TT,RDLARG
CAIN TT,-1
JRST M1TTPJ ;RETURN -1 FOR PEEKING AT "EOF"
PUSH P,A
HLRZ A,@RDLARG
JRST RDLTY3 ;ELSE RETURN CHAR, BUT DON'T FLUSH
RDLUNTYI:
MOVEI TT,(A)
JSP T,FXCONS
HRRZ B,RDLARG
PUSHJ P,CONS
MOVEM A,RDLARG
POPJ P,
READ6C: PUSH FXP,A
MOVEI T,R6C1
PUSHJ FXP,MKNR6C
SUB FXP,R70+1
JRST RINTERN
R6C1: ILDB TT,-1(FXP)
JUMPE TT,CPOPJ
ADDI TT,40
JRST POPJ1
;READ$ IREAD IREAD1 OREAD READ READ0
SUBTTL READ FUNCTION
;;; ********** HIRSUTE READER **********
READ$: MOVEI T,0
JRST READ
IREAD: MOVEI T,0
IREAD1: SKIPE VOREAD
JCALLF 16,@VOREAD
OREAD: JSP D,INCALL
SFA% QOREAD
SFA$ [SO.RED,,],,QOREAD
READ: MOVEI A,QOREAD ;ENABLE TTY PRE-SCAN
HRLM A,BFPRDP
MOVEI A,RDIN
HRRZ T,BFPRDP
JUMPN T,READ0 ;OOOOPS, A RE-ENTRANT CALL TO READ
PUSHJ P,READ0B ;TOP-LEVEL READ
HLLZS BFPRDP
SKIPA B,RDBKC
READ0: PUSHJ P,REKRD ;RE-ENTRANT READ
TLC T,21000 ;LOSING SPLICING MACROS AT TOP LEVEL
TLCN T,21000
JRST READ ;JUST GO AROUND AND TRY AGAIN
TLNE B,100000 ;IF WE ENDED WITH A PSEUDO-SPACE
TLNN B,40 ; (40-BIT SET IN SPACE SYNTAX),
TLNN T,60 ; OR IF OBJECT WASN'T AN ATOM,
POPJ P, ; THEN DO NOT BUFFER BACK A CHAR
JSP R,RVRCT ;OTHERWISE MUST UNTYI A CHARACTER
EXCH A,C
PUSHJ P,@UNTYIMAN
JRST CRETJ
;READ0B RD0B1 RD0B2A RD0BRM RVRCT
;;; ***** HERE IT IS FANS, THE BASIC READER *****
READ0B: HRRZM A,RDINCH ;READ-IN CHANNEL FILTER
RD0B1: JSP T,RSXST
HRRZ A,VIBASE
IFN USELESS,[
CAIN A,QROMAN
JRST RD0BRM
] ;END OF IFN USELESS
SKOTT A,FX
JRST IBSERR
MOVE TT,(A)
JUMPLE TT,IBSERR
CAIL TT,200
JRST IBSERR
IFN USELESS, SETZM RDROMP
RD0B2A: MOVEM TT,RDIBS
BG$ SUBI TT,10.
BG$ MOVEM TT,NRD10FL
MOVSI T,3 ;TOP LEVEL, FIRST OF LIST FLAGS
PUSHJ P,RDOBJ1 ;READ ONE OBJECT
HRRZS A
SETZB C,AR1
MOVEI AR2A,0
POPJ P,
IFN USELESS,[
RD0BRM: MOVEI TT,10.
SETOM RDROMP
JRST RD0B2A
] ;END OF IFN USELESS
RVRCT: MOVE C,VREADTABLE
MOVSI TT,-LRCT+2
CAME B,@TTSAR(C)
AOBJN TT,.-1
JUMPGE TT,ER3 ;BLAST? - READ
MOVEI C,(TT)
JRST (R)
;READ0A RMCER REKRD REKRD1 RDOBJ3 RDOBJ1 RDOBJ RDOBJ0
READ0A: PUSHJ P,REKRD
TLNN T,4060
RMCER: LERR EMS5 ;READ MACRO CONTEXT ERROR
POPJ P,
REKRD: SAVE RDINCH RDIBS
PUSHJ P,READ0B
REKRD1: RSTR RDIBS RDINCH
POPJ P,
RDOBJ3: TLNE B,RS%WSP ;TAB,SPACE,COMMA
JRST RDOBJ1
TLNN T,1
POPJ P,
HRRZ TT,BFPRDP
JUMPN TT,RMCER
RDOBJ1: JSP TT,RDCHAR ;*** READ ONE OBJECT ROUTINE ***
RDOBJ: NWTN N,B,OBB ;OBJECT BEGIN CHAR - NOT USAGE AT TYIPEEK
JRST RDOBJ3
MOVSI TT,400000 ;REALLY INTO THE READ NOW
IORM TT,BFPRDP
TLNE B,RS%MAC
JRST RDOBJM ;MACRO CHAR.
TLNE B,RS%SCO
JRST RDCHO1 ;SINGLE CHAR OBJ.
NWTNE B,RS.<LTR+XLT>
JRST RDALPH ;RDOBJ WILL EXIT WITH OBJECT READ
TLNE B,RS%LP ;IN ACC A, AND RCT ENTRY OF BREAK
JRST RDLST ;CHARACTER IN ACC B
NWTNE B,RS.DIG
JRST RDNUM
NWTNE B,RS.SGN
JRST RDOBJ6 ;+,-
MOVE AR1,B
JSP TT,RDCHAR ;DEFAULT IS . <DOT>
TLNN AR1,RS.PNT
JRST RDOBJ0 ;WAS DOTTED PAIR POINT ONLY
NWTNE B,RS.DIG ;IS NEXT CHAR A DIGIT?
JRST RDOBJ5 ;IF SO, THEN MUST BE FLOATING NUM COMING UP
TLNN AR1,RS%DOT
JRST RDJ2A ;IF NOT DOTTED PAIR, THEN TRY ALPHABETIC
RDOBJ0: TLNE AR1,RS%DOT ;*** DOT IS DOTTED-PAIR DOT ***
TLNE T,1
JRST ER2
TLOE T,4 ;LOSE IF ALREADY IN DOTTED PAIR
JRST ER2
TLNN T,200000 ;SO GET SECOND PART OF DOTTED PAIR
JRST RDOBJ ; BUT IF HUNK, THEN DO SOME CHECKING FIRST
PUSHJ P,RDSKWH
POPJ P, ;ENCOUNTERED %RP, EXIT LOOKING LIKE SECOND
TLZ T,4 ; PART OF DOT-PAIR TO SIGNAL HUNK ENDING
JRST RDOBJ
;RDJ2A RDOBJ5 RDOBJ2 RDJ2A1 RDOBJ6 RDJ6A RDOBJ7 ER1 RDOBJ4 RD8W RD8N
;;;. WITH DECIMAL SYNTAX ONLY TURNS INTO SCO, IF FOLLOWED BY BREAK
;;;OR BEGINNING OF ALPHA IF FOLLOWED BY ALPHA
RDJ2A: TLNN B,RS%<BRK+SCO+WSP+LP+DOT+RP+MAC+SLS+RBO>
NWTNN B,RS.<PNT+ARR+SGN+XLT+LTR>
JRST RDCHO4
JRST RDJ2A1
RDOBJ5: TLOA T,200 ;FOUND FLOATING NUM
RDOBJ2: TLO T,10000 ;NUM FORCED WITH "+"
RDJ2A1: JSP TT,IRDA
IDPB AR1,C
AOS D
JRST RDNUM2
RDOBJ6: JSP TT,IRDA ;PROCESS OBJ BEGINNING WITH + OR -
IDPB B,C
SOS D
NWTNE B,RS.ALT
TLO T,400 ;-
JSP TT,RDCHAR
JRST @RDOBJ8 ;CHECK FOR WHITE'S + HAC, USING RD8W, OR DONT BOTHER, USING RD8N
RDJ6A: TLNE B,RS%<MAC+RP+LP+SCO+WSP>
JRST RDOBJ4
NWTNN B,RS.PNT
JRST ER1
MOVE AR1,B
JSP TT,RDCHAR
TLNE T,4
JRST ER1
JRST RDOBJ5 ;+.D DECIMAL FLOATING FORMAT
RDOBJ7: NWTNE B,RS.DIG
JRST RDNUM2 ;+<DECIMAL DIGIT>
TLO T,20 ;+<ALPHA CHARA> OR +<EXTENDED ALPHA>
JRST RDA1
ER1: LERR MES2
RDOBJ4: TLO T,20 ;SINGLE CHARA "+" OR "-"
JRST RDBK
RD8W: NWTNE B,RS.<DIG+LTR>
JRST RDOBJ2
JRST RDJ6A
RD8N: NWTNE B,RS.<SGN+DIG+LTR+XLT>
JRST RDOBJ7
JRST RDJ6A
;RDNUM RDNUM2 RDNM10 RDNUM1 RDNUM8 RDNUM7 RDNUM9 RDNM9E RDNM9B RDNM9C
RDNUM: JSP TT,IRDA ;*** NUMBER ATOM ***
RDNUM2:
IFE BIGNUM, SETZM AR1 ;FLAG INDICATES HOW MANY DIGITS BEYOND OVERFLOW
RDNM10: SETZB F,R ;BASE 10. NUMBER IN R, BASE IBASE IN F
TLOA T,40
RDNUM1: JSP TT,RDCHAR
NWTNE B,RS.PNT
JRST RDNUM4 ;DECIMAL POINT [WITHOUT BREAK BIT SET]
SOSLE D
IDPB B,C
NWTNE B,RS.DIG
JRST RDNUM5
TLNE T,300 ;ALPHA CHAR SEEN
JRST RDNUM8
NWTNN B,RS.LTR
JRST RDNUM7
TLNN T,10000
JRST RDNUM6
NW% MOVEI TT,(B) ;GET CHTRAN
NW$ HRRZ TT,B
NW$ ANDI TT,177
CAIL TT,"a ;ALLOW FOR LOWER CASE LETTERS
SUBI B,"a-"A
SUBI B,"A-"0-10. ;LETTERS ARE SUPRA-DECIMAL:
JRST RDNUM5 ; A=10., B=11., ..., Z=35.
RDNUM8:
NW% CAIE A,"E ;UPPER AND LOWER CASE E ALLOWED
NW% CAIN A,"e ;MUST TIDY THIS UP SOMEDAY
NW$ TLNE B,RS%SQX ;EXPONENT OR (SOMEDAY) STRING-QUOTE
JRST RDNM8A
NWTNN B,RS.XLT
JRST ER1
RDNUM7: TLNE T,37000 ;EXTENDED ALPHA CHAR SEEN
JRST ER1
NWTNN B,RS.ARR
JRST RDNUM6
NWTNE B,RS.ALT
TLOA T,2000 ;←
TLO T,1000 ;↑
BG$ SKIPN NRD10FL ;IF WE ARE READING IN BASE 10., THEN
BG$ TLO T,100 ; F HAS NOTHING IN IT - SO MUST TAKE R
RDNUM9: TLNN T,140000
JRST RDNM9E
TLNE T,300 ;FOR EXPONENT-IFIED BIGNUMS, RDNSV WILL
HRR AR2A,AR1 ;BE MEANINGLESS
HRLI AR2A,0
TLNE T,400 ;BIGNUM OF CORRECT BASE AND SIGN IS PUT IN AR2A
TLO AR2A,-1
JRST RDNM9B
RDNM9E: TLNE T,300
MOVE F,R
TLNE T,400
MOVNS F
MOVEM F,RDNSV
RDNM9B: TLZ T,500 ;ZERO OUT SIGN AND DECIMAL BITS
MOVEI D,BYTSWD*LPNBUF
JSP TT,RDCHAR
RDNM9C: NWTNN B,RS.<DIG+SGN>
JRST ER1
NWTNN B,RS.SGN
JRST RDNM10
NWTNE B,RS.ALT ;SKIP IF +
TLO T,400
JSP TT,RDCHAR
JRST RDNM10
;RDNUM0 RDNUM6 RDNM8A RDNMF RDNM2 RDNM2A RDFXNM RDFX1 RDFL1
RDNUM0: IDPB B,C
RDNUM6: TLZ T,340 ;TWAS REALLY AN ALPHA ATOM
TLO T,20
JRST RDA3
RDNM8A: TLZ T,100
TLO T,1200
MOVEM D,RDDSV
JRST RDNUM9
RDNMF: JRST 2,@[.+1] ;CLEAR OUT ALL ARITHMETIC OVERFLOW BITS
MOVE B,T
MOVE TT,F ;FINISHED WITH NUMBER READ, SO PICK UP NUMBER IN BASE IBASE
BG$ SKIPN NRD10FL
BG$ TLO T,100
TLNN T,300
JRST RDNM2
MOVE TT,R ;PICK UP NUMBER IN BASE 10.
IFE BIGNUM,[
JUMPE AR1,RDNM2 ;NUMBER OF OVERFLOW DIGITS IN AR1
TLNN T,200
JRST RDNMER
ADDM AR1,D
ADDM AR1,RDDSV
]
RDNM2: TLNE T,400
MOVNS TT ;NEGATIVE NUMBER, IF INDICATED
BG$ TLNE T,140000
BG$ JRST RDBIGN
RDNM2A: TLNE T,200
JRST RDFLNM
RDFXNM: TLNE T,3000
JRST RDFXEX
RDFX1: JSP T,FIX1A
RDFL1: MOVE T,B
JRST RDNMX
;RDNUM5 RDNUMD RDNUMB RDIBOV RD10OV RDNUMC
RDNUM5: JFCL 8.,.+1 ;BASIC LOOP THAT INCREMENTALLY ADDS IN ONE DIGIT
IFE BIGNUM, JUMPN AR1,RDNUMC
IFN BIGNUM,[
TLNE T,40000
JRST RDBG10
]
RDNUMD: MOVE TT,R ;BASE 10. VALUE ACCUMULATES IN R
IMULI R,10. ;BASE IBASE VALUE IN F
NW% ADDI R,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD R,A
JFCL 8,RD10OV
IFN BIGNUM,[
TLNE T,100000 ;BIGNUM VALUE BASE 10. HELD IN AR1
JRST RDBGIB ;BIGNUM VALUE BASE IBASE HELD IN AR2A
RDNUMB: SKIPN NRD10FL
JRST RDNUM1
]
IFE BIGNUM, RDNUMB:
JFCL 8,.+1 ;MIGHT BE SET IF OVFL ON BASE 10. READIN, WENT TO RD10OV, DID A C1CONS,
MOVE TT,F ;DID A GC, HACKED AROUND AND SET IT AGAIN!
IMUL F,RDIBS
NW% ADDI F,-"0(B)
NW$ LDB A,[001100,,B]
NW$ ADD F,A
JFCL 8,RDIBOV
JRST RDNUM1
IFE BIGNUM,[
RDIBOV: MOVE F,T
MOVE T,TT ;OVERFLOW WHILE ACCUMULATING NUMBER
MUL T,RDIBS ;IN BASE IBASE. TRY TO RECUPERATE
LSH T+1,1 ;TO ALLOW, FOR EXAMPLE, 400000000000
LSHC T,35.
NW% ADDI T,-"0(B)
NW$ ADD T,A
EXCH T,F
JRST RDNUM1
RD10OV: MOVE R,TT
RDNUMC: AOJA AR1,RDNUMB
]
;RDFXEX RX1 RX1 RDFX2
RDFXEX:
IFN BIGNUM, CAIG A,77
TLNE T,600
JRST ER1
ANDI TT,777
EXCH TT,RDNSV
TLNN T,2000
JRST .+3
LSH TT,@RDNSV
JRST RDFX1
IFN BIGNUM,[
SKIPGE TT
TLO T,400
MOVMS TT
RX1: SOSGE RDNSV
JRST RDFX2
TLNE T,100000
JRST RDEX3
]
IFE BIGNUM,[
RX1: SOSGE RDNSV
JRST RDFX1
]
MUL TT,RDIBS
IFN BIGNUM,JUMPN TT,RDEXOF
LSH TT+1,1
LSHC TT,35.
JRST RX1
IFN BIGNUM,[
RDFX2: TLNE T,100000
JRST RDBIGM
TLNE T,400
MOVNS TT
JRST RDFX1
]
;RDFLNM RDFL3 RDFL3A RDFL2A RDFL2D RDL2D0 RDL2D3 RDL2D1 RDFL2E RDL2E0 RDL2E1 RDL2A0 RDL2A2 RDL2A1 RDL2A3
RDFLNM: TLNN T,1000
JRST RDFL3
MOVE D,RDDSV
ADD D,TT
AOS D
MOVE TT,RDNSV
RDFL3: HRREI R,-BYTSWD*LPNBUF-1(D)
IFN BIGNUM,[
TLZE T,140000
JRST RDFL3A
]
IDIVI TT,400000
SKIPE TT
TLC TT,254000
TLC TT+1,233000
FADL TT,TT+1
RDFL3A: MOVM T,R
RDFL2A: JUMPGE R,RDL2A2
RDFL2D: SETZ R,
CAIG T,30.
JRST RDL2D3
FSC TT,54. ;SCALE, SO THERE WONT BE UNDERFLOWS
MOVNI R,54.
RDL2D0: FDVL TT,[1.0↑8] ;LOOP FOR MULTIPLYING-IN NEGATIVE POWER OF 10.0
FDVR TT+1,[1.0↑8]
FADL TT,TT+1
SUBI T,8
RDL2D3: CAILE T,8
JRST RDL2D0
JUMPE T,RDFL2E
RDL2D1: FDVL TT,[10.0]
FDVR TT+1,[10.0]
FADL TT,TT+1
SOJG T,RDL2D1
RDFL2E: FADR TT,TT+1
FSC TT,(R)
JFCL 8,RDL2E1
RDL2E0: JSP T,FPCONS
JRST RDFL1
RDL2E1: JSP T,.+1
SKIPE VZUNDERFLOW
TLNN T,100 ;RANDOM FP UNDERFLOW BIT
JRST RDNMER
MOVEI TT,0
JRST RDL2E0
RDL2A0: MOVE TT+2,TT+1 ;LOOP FOR MULTIPLYING-IN POSITIVE POWER OF 10.0
FMPR TT+2,[1.0↑8]
FMPL TT,[1.0↑8]
UFA TT+1,TT+2
FADL TT,TT+2
SUBI T,8
RDL2A2: CAIL T,8
JRST RDL2A0
JUMPE T,RDL2A3
RDL2A1: MOVE TT+2,TT+1
FMPRI TT+2,(10.0)
FMPL TT,[10.0]
UFA TT+1,TT+2
FADL TT,TT+2
SOJG T,RDL2A1
RDL2A3: SETZ R,
JRST RDFL2E
;RDLST RDLSTA RDLSAA RDHNK1 RDLST1 RDLST0 RDLST3 RDLSX RDLSX1 RDLS3D RDLST4 RDLS4A RDLS4B RDHNK RDSKWH
RDLST: AOS BFPRDP
PUSH P,T ;*** READ LIST ***
PUSH P,R70 ;POINTER TO LAST OF FORMING LIST
HRLZI T,2
JRST RDLST3
RDLSTA: TLZE T,2 ;"ADD" AN ITEM TO A FORMING LIST
JRST RDLSAA
HLR B,(P) ;IFN NEWRD,??
HRRM A,(B)
JRST (TT)
RDLSAA: MOVEM A,(P)
JRST (TT)
RDHNK1: TLZN T,4060 ;IF THE NULL ITEM, FOLLOWED BY %RP
JRST RDLSX ; FOR HUNK, THEN EXIT.
RDLST1: PUSHJ P,NCONS ;GOT NEXT ITEM FOR LIST (OR HUNK)
JSP TT,RDLSTA
HRLM A,(P)
RDLST0: TLZ T,-1#200002 ;ZAP OUT OBJECT BITS, EXCEPT FOR "HUNK" AND
SKIPA B,AR2A ; "FIRST OBJECT" (MAYBE null splicing macro
RDLST3: JSP TT,RDCHAR ; causes return to here with nothing accumulated).
PUSHJ P,RDOBJ
TLZE T,4
JRST RDLST4 ;OJBECT JUST READ WAS PRECEEDED BY A DOT
MOVEM B,AR2A
TLZE T,20000
JRST RDLS3D ;MACRO-PRODUCED OBJ RETURNED
TLNE T,200000
JRST RDHNK1 ;CONTINUING WITH A HUNK
TLNE T,24060 ;EXIT IF NO OBJECT READ
JRST RDLST1
RDLSX: TLNN B,RS%RP
LERR EMS6 ;BLAST, MISSING ")"
SOS BFPRDP
POP P,A
TLZE T,200000
PUSHJ P,MAKHUNK
POP P,T
RDLSX1: MOVSI B,RS%<BRK+WSP> ;THROWAWAY BREAK-CHARACTER
TLO T,4000
POPJ P,
RDLS3D: TLNN T,4060 ;MACRO-OBJECT RETURNED WITHIN A LIST
JRST RMCER
TLNN T,1000
JRST RDLST1 ;NORMAL MACRO OBJECT
TLZ T,-1#200002 ;DONT FLUSH "HUNK" OR "1ST OBJ OF LIST" BITS
JUMPE A,RDLST0
JSP TT,RDLSTA
JSP AR1,RLAST ;SPLICING MACRO OBJECT
HRLM A,(P)
JRST RDLST0
RDLST4: JUMPN T,RDLS4A ;OJBECT JUST READ WAS PRECEEDED BY A DOT
SKIPN VMAKHUNK
JRST ER2
TLO T,200000 ; BUT NOTHING AFTER THE DOT EXCEPT A %RP
JRST RDLSX
RDLS4A: TLNE T,2 ;*** DOT PAIR ***
JRST ER2
TLZ T,60
TLNE T,200000 ;COMBINATION OF "HUNK" AND "DOT" BITS ON
JRST RDLSX ; WHEN EXITING FROM RDOBJ MEANS ".)" CASE
MOVS TT,(P)
HRRM A,(TT)
TLZE T,20000
TLZN T,1000 ;OJBECT IMMEDIATELY FOLLOWING "DOT" IS
JRST RDLS4B
MOVE AR2A,RCT0+". ;MACRO-PRODUCED SPLICING OBJECT AS "DOT"+OBJ
JUMPE A,RDLST0 ;THROW AWAY IF RETURN ()
HRRZ AR2A,(A)
JUMPN AR2A,ER2
HLRZ AR2A,(A)
HRRM A,(TT)
RDLS4B: PUSHJ P,RDSKWH ;SCAN CHARS FOLLOWING OBJ TO RIGHT OF DOT
JRST RDLSX ; HOPEFULLY, NEXT INTERESTING ONE IS A %RP
TLNE B,RS%DOT
JRST RDHNK ;IF ITS ANOTHER DOT, THEN WE HAVE A HUNK
TLNE B,RS%MAC
NWTNN B,RS.ALT
JRST ER2
PUSHJ P,RDOBJM ;SPLICING MACRO AFTER "DOT"+OBJECT
JUMPE A,RDLS4B ;THROW AWAY IF RETURN ()
HLRZ AR2A,(P)
HRRZ C,(AR2A)
HRRM A,(AR2A)
JSP AR1,RLAST
HRRM C,(A)
HRLM A,(P)
JRST RDLS4B
RDHNK: SKIPN VMAKHUNK
JRST ER2
TLO T,200000 ;BEGIN NOTICING THAT THIS IS A HUNK
MOVS TT,(P)
HRRZ A,(TT) ;UNDO THE CDR OF THE CELL
PUSHJ P,NCONS
HRRM A,(TT)
HRLM A,(P)
JRST RDLST3
RDSKWH: TLNE B,RS%RP ;RIGHT PAREN? THEN EXIT NORMALLY
POPJ P,
NWTN E,B,WTH
JRST POPJ1 ;EXIT BY SKIPPING IF "INTERESTING" CHAR IS NOT PARENS
JSP TT,RDCHAR ;IF CHAR IS UNWORTHY, THEN FLUSH IT AND TRY AGAIN
JRST RDSKWH
;RDOBJM RDALPH RDA0 RDA1 RDA3 RDA4 RLAST RLAST1 RDCHO1 RDCHO4 RDCHO3 RDCHO RDCHO2
RDOBJM: TLO T,20000 ;*** MACRO CHARACTER ***
NWTNE B,RS.ALT ;SPLICING?
TLO T,1000 ;SPLICING MACRO
PUSH P,T
SETZM RDBKBF
NW% CALLF 0,(B) ;MACRO CHARACTER HAS LINK IN RH OF
IFN NEWRD,[
LDB D, [001100,,B]
PUSHJ P, GETMAC
HRRZ A, (A)
CALLF 0, (A)
] ;END OF IFN NEWRD
JSP T,RSXST
POP P,T
SKIPN B,RDBKBF
JRST RDLSX1
TLO T,60
POPJ P,
RDALPH: TLO T,20 ;*** PNAME ATOM ***
SETOM LPNF
RDA0: JSP TT,IRDA1
RDA1: IDPB B,C
RDA3: JSP TT,RDCHAR
SOJG D,RDA1
MOVEM B,AR2A
PUSHJ FXP,RDA4
MOVE B,AR2A
JRST RDA0
RDA4: PUSHJ P,PNCONS ;ADDS ANOTHER SEGMENT TO A LONG PNAME LIST
AOSN LPNF
PUSH P,R70
MOVE B,(P)
EXCH A,B
PUSHJ P,.NCONC
MOVEM A,(P)
POPJ FXP,
RLAST: JUMPE A,(AR1)
RLAST1: HRRZ TT,(A)
JUMPE TT,(AR1)
LSH TT,-SEGLOG
SKIPL ST(TT)
JRST RMCER
HRRZ A,(A)
JRST RLAST1
RDCHO1: MOVE AR1,B
NWTNN B,RS.PNT
JRST RDCHO3
JSP TT,RDCHAR ;. AS SCO ALSO HAS DECIMAL PT. SYNTAX
NWTNE B,RS.DIG
JRST RDOBJ5 ;WILL TAKE AS FLOTING PT. NUM
NWTN N,B,WTH ;SKIP IF WORTHY CHAR
JRST RDCHO3 ;CAN TOSS OUT NEXT UNWORTHY CHAR
RDCHO4: PUSH FXP,B ;OTHERWISE, SAVE NEXT CHAR AS IF IT WERE IMPORTANT BREAK CHAR
SKIPA C,[RDCHO2]
RDCHO3: MOVEI C,RDLSX1
MOVE B,AR1
PUSH P,C
RDCHO: JSP TT,IRDA ;*** SINGLE CHARA OBJECT ***
SETZM PNBUF
IDPB B,C
JRST RINTERN
RDCHO2: POP FXP,B ;AFTER MAKING UP . AS SCO,
MOVEM B,RDBKC ;MAKE NEXT CHAR LOOK LIKE
TLO T,20 ;IMPORTANT BREAK CHAR
POPJ P,
;RD10OV RDIBOV RDBG10 RDBG1A RDBGIB RDBGIA .RDMULP .TIMER .TM.PL
IFN BIGNUM,[
RD10OV: TLO T,40000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR1,A
JRST RDBG1A
RDIBOV: TLO T,100000
JSP A,RDRGSV
PUSHJ P,C1CONS
MOVE AR2A,A
JRST RDBGIA
RDBG10: TLNE T,3000
JRST RDNUMD ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBG1A: MOVE T,AR1
MOVEI D,-"0(B)
NW$ ANDI D,177
MOVEI TT,10.
PUSHJ P,.TM.PL
MOVE T,TSAVE
TLNE T,100000
JRST RDBGIA
JSP A,RDRGRS
JRST RDNUMB
RDBGIB: TLNE T,3000
JRST RDNUMB ;GETTING EXPONENT MODIFIER
JSP A,RDRGSV
RDBGIA: MOVE T,AR2A
MOVE TT,RDIBS
MOVEI D,-"0(B)
NW$ ANDI D,177
PUSHJ P,.TM.PL
JSP A,RDRGRS
JRST RDNUM1
.RDMULP: SKIPA T,A
.TIMER: MOVEI D,0 ;T IS LIST OF DIGITS, TT IS MULTIPLIER,
.TM.PL: HLRZ A,(T) ;D IS CARRY.
MOVE R,(A)
MUL R,TT
ADD R+1,D
TLZE R+1,400000
AOS R
MOVEM R+1,(A)
MOVE D,R
HRRZ A,(T)
JUMPN A,.RDMULP
JUMPE D,CPOPJ
MOVE TT,D
PUSHJ P,C1CONS
HRRM A,(T)
POPJ P,
;RDRGSV RDRGRS RDEXOF RDEX3 RDBIGN RDBIGM
;;; IFN BIGNUM
RDRGSV: MOVEM T,TSAVE
MOVEM D,DSAVE
MOVEM R,RSAVE
MOVEM F,FSAVE
JRST (A)
RDRGRS: MOVE T,TSAVE
MOVE D,DSAVE
MOVE R,RSAVE
MOVE F,FSAVE
JRST (A)
RDEXOF: TLO T,100000
PUSH FXP,TT+1
PUSHJ P,C1CONS
MOVE B,A
POP FXP,TT
PUSHJ P,C1CONS
HRRM B,(A)
TLNE T,400
TLO A,-1
JRST RX1
RDEX3: PUSH P,A
MOVEM T,TSAVE
MOVE T,A
MOVE TT,RDIBS
PUSHJ P,.TIMER
MOVE T,TSAVE
POP P,A
JRST RX1
RDBIGN: TLNE T,3000
JRST RDBGEX
HRLI A,0 ;CREATE BIGNUM SIGN
TLNE T,400
TLO A,-1
TLNE T,100000
TLNE T,300
JRST RDCBG
HRR A,AR2A
RDBIGM: PUSHJ P,BNTRSZ
MOVE TT,[400000,,0]
JRST RDFX1
PUSHJ P,BNCONS
MOVE B,RDBKC
POPJ P,
;RDBGEX RDBGXM RDBFSH RDBXFL RDCBG RDCBG1 RDNM2B
;;; IFN BIGNUM
RDBGEX: TLNE T,200
JRST RDBXFL
MOVEI D,1
TLNE T,2000
JRST RDBFSH
JUMPLE TT,RDBGXM
IMUL D,RDIBS ;<BIGNUM>↑(TT)
SOJG TT,.-1
RDBGXM: MOVE TT,D
MOVEM T,TSAVE
HRRZ T,AR2A
PUSHJ P,.TIMER
MOVE A,AR2A
MOVE T,TSAVE
JRST RDBIGM
RDBFSH: LSH D,(TT) ;<BIGNUM>←(TT)
JRST RDBGXM
RDBXFL: ADD TT,RDDSV
SUBI TT,BYTSWD*LPNBUF
MOVE A,AR2A
JRST RDCBG1
RDCBG: TLNN T,300
JRST RDNM2B
HRR A,AR1
TLNN T,200
JRST RDBIGM
HRREI TT,-BYTSWD*LPNBUF-1(D)
RDCBG1: PUSH FXP,TT ;THIS IS THE POWER-OF-TEN EXPONENT
MOVE TT,A
PUSHJ P,FLBIGZ
POP FXP,R
JFCL 8.,RDNMER
JUMPGE A,RDFL3A
DFN TT,TT+1
JRST RDFL3A
RDNM2B: TLZ T,140000 ;A BIGNUMBER BASE 10. WAS REALLY A REGNUM
JRST RDNM2A ;BASE IBASE, BUT BIG ENOUGH TO OVFLO BASE 10. CALC
] ;END OF IFN BIGNUM
;RDCHAR RDCH1 RDBK RDNMX RDNUM4 RDNM4A
SUBTTL READER SINGLE-CHARACTER FILTER
;;; ***** READ ONE CHARACTER (FOR READ) *****
RDCHAR: PUSHJ P,@RDINCH
MOVE B,@RSXTB
RDCH1:
NW% JUMPGE B,(TT)
NW$ NWTNE B,RS%BRK
NW$ JRST (TT)
NWTN E,B,[<SQX+SCO+WSP+LP+DOT+RP+MAC+PNT>]
JRST RDBK ;BREAKING CHAR FOUND
NWTN N,B,WTH
JRST RDCHAR ;WORTHLESS CHAR
TLNN B,RS%SLS
JRST (TT) ;ALPHABETIC CHAR WITH BREAK BIT SOMEHOW SET
PUSHJ P,@RDINCH ;/
NW% HRR B,A ;PUT EXTENDED ALPHABETIC SYNTAX ON THIS CHAR
NW% HRLI B,2
NW$ MOVEI B,RS.XLT(A)
JRST (TT)
RDBK: MOVEM B,RDBKC
TLNN T,60
JRST (TT)
TLNN T,20
JRST RDNUM4
PUSHJ FXP,RDAEND
IFN USELESS, SKIPE RDROMP
IFN USELESS, PUSHJ P,RDROM
PUSHJ P,RINTERN
RDNMX: MOVE B,RDBKC
POPJ P,
RDNUM4: TLNN T,300
TLNN B,200
JRST RDNM4A
PUSHJ P,@RDINCH ;. FOUND
MOVE B,@RSXTB
NWTN N,B,SEE
JRST .-3 ;CONTROL-CHARS ARE IGNORED
MOVEI D,BYTSWD*LPNBUF+1
NWTNE B,RS.DIG
TLOA T,200
TLO T,100
JRST RDCH1
RDNM4A: TLNE B,RS.SGN
TLNN T,3000
JRST RDNMF ;TERMINATES A NUMBER TOKEN, UNLESS A SIGN IS
JRST (TT) ;FOLLOWING AN EXPONENTIATOR
;RDROM RDROM1 RDROM2 RDROM3 RDROM7 RDAEND IRDA IRDA1 RDIN
IFN USELESS,[
RDROM: SKIPGE LPNF
SKIPN PNBUF
POPJ P,
PUSH FXP,C
MOVE C,[440700,,PNBUF]
SETZB TT,D
RDROM1: ILDB F,C
JUMPN F,RDROM2
PUSH FXP,T
JSP T,FXCONS
POP FXP,T
SUB FXP,R70+1
JRST POPJ1
RDROM2: SETZ R,
IRP X,,[M,D,C,L,X,V,I]N,,[1000.,500.,100.,50.,10.,5,1]
CAIN F,"X
MOVEI R,N
TERMIN
JUMPE R,RDROM7
ADDI TT,(R)
CAIG R,(D)
JRST RDROM3
REPEAT 2, SUBI TT,(D)
RDROM3: MOVEI D,(R)
JRST RDROM1
RDROM7: POP FXP,C
POPJ P,
] ;END OF IFN USELESS
RDAEND: LSHC B,6
DPB B,[360600,,C]
SETZM B
LSHC B,-6
DPB B,C
SKIPGE LPNF
POPJ FXP,
PUSHJ P,PNCONS ;DESTROYS TT
POP P,B
EXCH A,B
PUSHJ P,.NCONC
POPJ FXP,
IRDA: SETOM LPNF ;INITIALIZE FOR READING PNAME-TYPE ATOM
IRDA1: MOVE C,PNBP
MOVEI D,BYTSWD*LPNBUF
JRST (TT)
RDIN: PUSHJ FXP,SAV5M1
PUSHJ P,SAVX5
PUSHJ P,@TYIMAN
MOVEI A,(TT) ;***** GRUMBLE *****
PUSHJ FXP,RST5M1
JRST RSTX5
;RDQTE RDSEMI RDSMI0 RDSMI1 RDVBAR RDVB2 RDVB3 RDVB4 CTRLQ CTRLS
SUBTTL BUILT-IN MACRO CHARACTER PROCESSORS
;;; SINGLE QUOTE PROCESSOR:
;;; 'FOO => (QUOTE FOO)
RDQTE: PUSHJ P,READ ;FOR THE WHITE SINGLE-QUOTE HAC
PUSHJ P,NCONS
MOVEI B,QQUOTE
JRST XCONS
;;; SEMICOLON COMMENT PROCESSOR: (SPLICING)
;;; ; -- ANYTHING -- <CR> => NIL, HENCE IGNORED
RDSEMI: PUSHJ P,RDSMI0
JUMPE A,CPOPJ ;OK, FOUND CR
LERR EMS10 ;HMMM, HIT E-O-F BEFORE CR
RDSMI0: MOVNI T,1
PUSH P,T
JSP D,INCALL
QRDSEMI ;THIS SHOULD NEVER [!!] BE USED
RDSMI1: PUSHJ P,TYI
SA$ CAIE A,%TXCTL+"M
SA$ CAIN A,%TXCTL+"m
SA$ JRST FALSE ;YET ANOTHER GODDAM SAIL CHARACTER SET SCREWUP
CAIE A,15 ;CR
JRST RDSMI1
JRST FALSE
;;; VERTICAL BAR PROCESSOR:
;;; |ANYTHING| => /A/N/Y/T/H/I/N/G
;;; I.E. IT IS A SUPER SYMBOL QUOTER (ALMOST LIKE ""'S)
RDVBAR: PUSH FXP,R70
JSP T,GTRDTB
MOVEI T,RDVB3
PUSHJ FXP,MKNR6C
SUB FXP,R70+1
JRST RINTERN
RDVB2: SETOM -1(FXP)
RDVB3: PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
SA% CAIN TT,↑M
SA$ CAIN T,203
SA$ JRST RDVB3
SA$ CAIN TT,%TXTCTL+"M
JRST RDVB2
CAIN TT,↑J
SKIPN -1(FXP)
JRST RDVB4
SETZM -1(FXP)
JRST RDVB3
RDVB4: SETZM -1(FXP)
CAIN TT,"|
POPJ P,
SKIPGE T,@TTSAR(AR2A)
TLNN T,2000
JRST POPJ1
PUSH FXP,D
PUSHJ P,TYI
POP FXP,D
CAIN TT,↑M
SETOM -1(FXP)
JRST POPJ1
;;; SPLICING MACRO CHARACTER FUNCTIONS FOR ↑Q AND ↑S.
CTRLQ: MOVEI A,TRUTH
MOVEM A,TAPRED
JRST FALSE
CTRLS: SETZM TTYOFF
JRST TERPRI
;%TXMTA %TXCTL %TXASC TTYBUF TTYB0 TTYB1 TTYB1E TTYB7 TTYB7E TTYB7G TTYB7F TTYB7H TTYB7N CLRSRN TTYB2 TTYB3 TTYB3A TTYB4 TTYB4C TTYB4G TTYB4J TTYB4M TTYB5 TTYB5H TTYB5K TTYB5M TTYB6 TTYB6C TTYB6F TTYB6J TTYB6Q TTYB9 TTYB9A TTYB9B TTYB9D TTYB9J TTYB8
SUBTTL NEWIO TTY PRESCAN, RUBOUT HANDLER, AND READLINE
;;; INITIAL TTY CHARACTER BUFFERING ROUTINE.
;;; BUFFERS UP A LIST OF CHARACTERS FOR TTY INPUT.
;;; HANDLES ALL APPROPRIATE RUBOUT PROCESSING.
;;; ARGUMENTS ARE A TTY INPUT FILE ARRAY IN A,
;;; THE FUNCTION TO BUFFER FOR IN B (E.G. QOREAD),
;;; AND THE COUNT OF UNMATCHED LEFT PARENS IN C.
;;; RUBOUT ECHOING IS PERFORMED ON THE ASSOCIATED OUTPUT
;;; TTY, IF ANY. HAIRY ERASING RUBOUT IS DONE FOR DISPLAYS.
;;; NO RUBOUT HACKING IS DONE IF THERE IS NO ECHO FILE.
;;; THESE ARE COMPATIBLE WITH THE ITS DEFINITIONS:
%TXMTA==:400 ;META BIT
%TXCTL==:200 ;CONTROL BIT
%TXASC==:177 ;ASCII CODE
TTYBUF: JSP T,SPECBIND
VECHOFILES
0 A,VINFILE
CAIN A,TRUTH
HRRZ A,V%TYI
PUSH FXP,(C)
CAIE C,QOREAD
SETZM (FXP)
JSP T,GTRDTB ;GET READTABLE;AR2A 4.9 = USEFULP
CAIN B,Q%READLINE ;AR2A 4.9 => USEFULP
TLO AR2A,200000 ;AR2A 4.8 => READLINE
MOVEI TT,LRCT-2
HLRZ C,@TTSAR(AR2A)
SKIPE C
TLO AR2A,100000
MOVEI TT,FT.CNS ;GET ASSOCIATED OUTPUT TTY
SKIPE C,@TTSAR(A) ; (THE SIGN BIT TELLS TYO6 THIS IS ONE FILE)
PUSHJ P,TTYBRC ;MAYBE GET CURCOR POSITION IN D
TTYB0: PUSH FXP,D
PUSH FXP,-1(FXP) ;PARENS COUNT
MOVEI TT,F.MODE
MOVE R,@TTSAR(A) ;GET INPUT FILE MODE BITS
PUSH FXP,R
PUSH FXP,XC-1 ;PUSH -1 (NOT IN STRING YET)
SETZ B, ;B HOLDS LIST OF CHARACTERS
PUSH P,BFPRDP
HRRZS BFPRDP ;WE WANT NO CLEVERNESS FROM $DEVICE
;STATE OF THE WORLD:
; B HAS LIST OF BUFFERED CHARS (IN REVERSE ORDER)
; C HAS TTY OUTPUT FILE ARRAY
; AR2A HAS READTABLE
; 4.9 => USEFUL CHAR SEEN
; 4.8 => READLINE INSTEAD OF READ
; 4.7 => (STATUS TTYREAD) = T
; VINFILE HAS TTY INPUT FILE ARRAY
; P: OLD CONTENTS OF BFPRDP
; FXP: STRING TERMINATOR CHAR (-1 IF NOT IN STRING)
; MODE BITS FOR INPUT FILE
; PARENTHESIS COUNT
; SAVED CURSOR POSITION
; ORIGINAL PARENS COUNT
TTYB1: PUSHJ P,TTYBCH ;GET A CHARACTER
MOVE D,@TTSAR(AR2A) ;GET READTABLE SYNTAX
MOVE R,-1(FXP) ;GET MODE BITS
IFN SAIL,[
CAIE TT,%TXCTL+"M
CAIN TT,%TXCTL+"m
JRST TTYB1E
] ;END IFN SAIL
CAIE TT,↑M
JRST TTYB7
TTYB1E: TLNE AR2A,200000 ;CR TERMINATES READLINE
JRST TTYB9
TLNN R,FBT<LN> ;SKIP IF LINE MODE
JRST TTYB2
MOVEI TT,203 ;PSEUDO-SPACE
TLNN AR2A,200000 ;SKIP IF HACKING A STRING
JSP R,TTYPSH ;ELSE PUSH CHAR ONTO BUFFER
SA% MOVEI TT,↑M
SA$ MOVEI TT,%TXCTL+"M
JRST TTYB9 ;ALL DONE
TTYB7:
IFN SAIL,[
CAIE TT,%TXCTL+"K
CAIN TT,%TXCTL+"k ;LOWER CASE K
JRST TTYB7E
; TLNN R,FBT.FU
] ;END OF IFN SAIL
CAIE TT,↑K ;FOR A ↑K, WE TERPRI
JRST TTYB7F ; AND THEN RETYPE THE BUFFER
TTYB7E: SKIPN AR1,C
JRST TTYB1
TTYB7G: PUSHJ P,ITERPRI
JRST TTYB7N
TTYB7F:
IFN SAIL,[
CAIE TT,%TXCTL+"L
CAIN TT,%TXCTL+"l ;LOWER CASE L
JRST TTYB7E
; TLNN R,FBT.FU
] ;END OF IFN SAIL
CAIE TT,↑L ;RPUSH FXPFOR ↑L, WE CLEAR THE SCREEN,
JRST TTYB2 ; THEN RETYPE THE BUFFER
TTYB7H: SKIPN AR1,C
JRST TTYB1
MOVEI TT,F.MODE
MOVE R,@TTSAR(AR1)
TLNN R,FBT<CP> ;IF WE CAN'T CLEAR THE SCREEN,
JRST TTYB7G ; WE JUST MAKE LIKE ↑K
PUSHJ P,CLRSRN
TTYB7N: PUSHJ P,TTYBRC ;READ THE TTY CURSOR POSITION
MOVEM D,-3(FXP)
PUSHJ P,TTYBLT ;ZAP OUT TTY BUFFER
JRST TTYB1
IFN D10,[
CLRSRN: PUSH P,A ;SAVE A OVER TYO
MOVEI A,14 ;↑L
PUSHJ P,TYO
POP P,A
POPJ P,
];END IFN D10
TTYB2: TLNN AR2A,200000 ;READLINE IGNORES SLASHES
TLNN D,2000 .SEE SYNTAX ;SLASH
JRST TTYB4
JSP R,TTYPSH
PUSHJ P,TTYBCH
TLO TT,400000 ;SLASHIFIED CHAR
TTYB3: TLO AR2A,400000 ;USEFUL FROB SEEN
TTYB3A: JSP R,TTYPSH
JRST TTYB1
TTYB4: TLNE D,1000 .SEE SYNTAX ;RUBOUT
TLNE D,40 .SEE SYNTAX ;NOT SECOND CHOICE
JRST TTYB5
JUMPN B,TTYB4C
HRRZ T,BFPRDP
JUMPE T,TTYB9J ;RETURN TO CALLER FOR EOF
SKIPE AR1,C ;OOPS! INSIDE READ ALREADY!
PUSHJ P,ITERPRI ; WE MUST SIMPLY TERPRI
JRST TTYB1 ; (IF POSSIBLE) AND TRY IT AGAIN
TTYB4C: PUSHJ P,RUB1CH ;RUB OUT CHAR
SKIPL TT,(A) ;SKIP IF CHAR WAS SLASHIFIED
JRST TTYB4G
PUSHJ P,RUB1CH ;RUB OUT SLASH TOO
JRST TTYB1
TTYB4G: SKIPL (FXP) ;SKIP UNLESS IN STRING
JRST TTYB4J
TLNE TT,100000
JRST TTYB4M
MOVE D,@TTSAR(AR2A) ;GET CHARACTER SYNTAX
TLNE D,40000 .SEE SYNTAX ;OPEN PAREN
SOS -2(FXP)
TLNE D,10000 .SEE SYNTAX ;CLOSE PAREN
AOS -2(FXP)
JRST TTYB1
TTYB4J: TLNE TT,200000 ;RUBBED OUT BACK OUT OF STRING
SETOM (FXP)
JRST TTYB1
TTYB4M: HRRZM TT,(FXP) ;RUBBED OUT BACK INTO A STRING
JRST TTYB1
TTYB5: TLNE AR2A,200000 ;GO BACK AROUND IF READLINE
JRST TTYB3A
SKIPGE R,(FXP) ;SKIP IF IN STRING
JRST TTYB5H
CAIE R,(TT)
JRST TTYB3A
TLO TT,100000 ;MARK AS STRING END
SETOM (FXP)
JRST TTYB3A
TTYB5H: TLNE D,1000 .SEE SYNTAX ;FORCE FEED
TLNN D,40 .SEE SYNTAX ;SECOND CHOICE
JRST TTYB5K
JSP R,TTYPSH
JRST TTYB9A
TTYB5K: TLNN D,100000 .SEE SYNTAX ;SPACE
JRST TTYB6
TTYB5M: JSP T,TTYATM
JRST TTYB3A
TTYB6: TLNN D,200000 .SEE SYNTAX ;SINGLE CHAR OBJECT
JRST TTYB6C
TLO AR2A,400000 ;USEFUL THING SEEN
JRST TTYB5M
TTYB6C: MOVEI R,(D)
MOVEI F,↑M
CAIN R,QRDSEMI
JRST TTYB6F
MOVEI F,"|
CAIE R,QRDVBAR
JRST TTYB6J
TLO AR2A,400000 ;USEFUL FROB SEEN
TTYB6F: TLO TT,200000 ;STRING BEGIN
MOVEM F,(FXP)
JRST TTYB3
TTYB6J: TLNN D,40000 .SEE SYNTAX ;OPEN PAREN
JRST TTYB6Q
AOS -2(FXP)
JRST TTYB3
TTYB6Q: TLNN D,10000 .SEE SYNTAX ;CLOSE PAREN
JRST TTYB8
JSP T,TTYATM
SOSLE -2(FXP)
JRST TTYB3
TTYB9: JSP R,TTYPSH
TLNN AR2A,100000
JRST TTYB1 ;ONLY FORCE-FEED ENDS TTYSCAN
TTYB9A: JUMPE C,TTYB9B
PUSHJ P,TTYBRC
MOVEI TT,AT.LNN ;UPDATE LINENUM AND CHARPOS
HLRZM D,@TTSAR(C) ; OF ASSOCIATED OUTPUT FILE
MOVEI TT,AT.CHS
HRRZM D,@TTSAR(C)
TTYB9B: MOVEI A,(B)
PUSHJ P,NREVERSE
MOVEI B,(A)
MOVEI C,(A)
TTYB9D: JUMPE C,TTYB9J
HLRZ A,(C)
MOVE TT,(A)
TLZE TT,-1
JSP T,FXCONS
HRLM A,(C)
HRRZ C,(C)
JRST TTYB9D
TTYB9J: SUB FXP,R70+5
POP P,BFPRDP ;RESTORE BFPRDP
MOVEI A,(B)
JRST UNBIND
TTYB8: TLNE D,277237 .SEE SYNTAX ;SKIP IF NOT WORTHY CHAR
JRST TTYB3
JRST TTYB3A
;RCPOS TTYBRC TTYBR1 TTYPSH TTYPS1 TTYATM TTYBCH TTYBLT TTYBL4 TTYBL1 TTYBL2
IFN ITS,[
RCPOS: SETZ
SIXBIT \RCPOS\ ;READ CURSOR POSITION
,,@TTSAR(AR1) ;TTY CHANNEL #
2000,,D ;MAIN PROGRAM CURSORPOS
402000,,R ;ECHO AREA CURSORPOS
] ;END OF IFN ITS
TTYBRC: HRROS AR1,C ;GET CURSOR POSITION IN D
TTYBR1: MOVE TT,TTSAR(AR1)
PUSHJ P,IFORCE
IFN ITS,[
MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
MOVEI TT,F.CHAN ;C HAS OUTPUT FILE FOR ECHOING
.CALL RCPOS ;READ CURSOR POSITION INTO D
.VALUE
TLNE F,FBT<EC>
MOVE D,R ;MAYBE NEED ECHO AREA CURSOR
POPJ P,
] ;END OF IFN ITS
IFN D10,[
SETZ D, ;? WHAT TO DO?
POPJ P,
] ;END OF IFN D10
IFN D20,[
PUSHJ FXP,SAV3 ;PRESERVE LOW THREE AC'S
MOVEI TT,F.JFN
HRRZ 1,@TTSAR(AR1)
RFPOS
MOVE D,2
PUSHJ FXP,RST3
POPJ P,
] ;END OF IFN D20
TTYPSH:
IFN 0,[
ANDI TT,%TXCTL+%TXASC ;? FOLD CHARACTER DOWN TO 7 BITS
TRZN TT,%TXCTL
JRST TTYPS1
CAIE TT,177
TRZ TT,140
TTYPS1:
] ;END OF IFN 0
JSP T,FXCONS ;PUSH CHAR IN TT ON FRONT
PUSHJ P,CONS ; OF LIST OF BUFFERED CHARS
MOVEI B,(A)
JRST (R)
TTYATM: JUMPGE AR2A,(T) ;DECIDE WHETHER WE MAY HAVE
MOVE R,-1(FXP) ; TERMINATED A TOP LEVEL ATOM,
SKIPG -2(FXP) ; AND IF SO GO TO TTYB9 AND OUT
TLNE R,FBT<LN> ;WE HAVE *NOT* TERMINATED IF:
JRST (T) ; NO USEFUL CHARS SEEN YET
TLNN AR2A,100000 ; (STATUS TTYREAD) = NIL
JRST (T) ; OPEN PARENS ARE HANGING
JRST TTYB9 ; TTY INPUT IS IN LINE MODE
TTYBCH: PUSHJ P,$DEVICE ;GOBBLE A CHARACTER
IFN ITS,[
ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER TO 7 BITS
TRZN TT,%TXCTL
POPJ P,
CAIE TT,177
TRZ TT,140
MOVEI D,(TT) ;ATTEMPT TO FLUSH INTERRUPT CHARS
ROT TT,-1
ADDI TT,FB.BUF ;REALLY SHOULD BE MORE CLEVER
HRRZ AR1,VINFILE
HLRZ R,@TTSAR(AR1)
SKIPGE TT
HRRZ R,@TTSAR(AR1)
JUMPN R,TTYBCH
MOVEI TT,(D)
] ;END OF IFN ITS
POPJ P,
TTYBLT: SKIPN AR1,C
POPJ P,
MOVEI A,(B) ;TYPE OUT ALL BUFFERED CHARS
PUSHJ P,NREVERSE ; ONTO THE ECHO OUTPUT FILE
MOVEI B,(A)
SKIPG -4(FXP) ;IF WE ENTERED WITH HANGING
JRST TTYBL1 ; PARENS, PRINT THEM
PUSH FXP,-4(FXP)
TTYBL4: MOVEI TT,"(
PUSHJ P,TYOFIL
SOSLE (FXP)
JRST TTYBL4
SUB FXP,R70+1
MOVEI TT,40
PUSHJ P,TYOFIL
TTYBL1: JUMPE B,TTYBL2 ;ECHO ALL CHARS TO ECHO TTY
HLRZ C,(B)
HRRZ TT,(C)
PUSHJ P,TYOFIL
HRRZ B,(B)
JRST TTYBL1
TTYBL2: PUSHJ P,NREVERSE
MOVEI B,(A) ;RESTORE BACKWARDS LIST OF CHARS
MOVE C,AR1 ;RESTORE C (NREVERSE CLOBBERED)
POPJ P,
;RUBOUT RUB1CH RSTCUR RSTCU3 RUB1C1 RUB1C3
RUBOUT: MOVEI D,QRUBOUT ;LSUBR (1 . 2)
CAMGE T,XC-2
JRST WNALOSE
JUMPE T,WNALOSE
CAME T,XC-2
SKIPA AR1,V%TYO
POP P,AR1
POP P,A
JSP F,TYOARG
MOVEI A,(TT)
PUSHJ P,TOFLOK
PUSHJ P,RUB1C1
JRST UNLKTRUE
SETZ A,
UNLKPOPJ
RUB1CH: HLRZ A,(B) ;DELETE CHAR FROM BUFFERED LIST
HRRZ B,(B)
JUMPE C,CPOPJ ;THAT'S IT IF NO ECHO FILE
PUSH P,A
HRRZ A,(A) ;GET CHARACTER IN A
MOVEI AR1,(C)
PUSHJ P,RUB1C1
JRST POPAJ
IT$ PUSHJ P,RSTCUR ;MUST RETYPE WHOLE STRING IN PLACE
PUSHJ P,TTYBLT
IT$ PUSHJ P,CNPL
JRST POPAJ
IFN ITS,[
RSTCUR: ;RESTORE SAVED CURSOR POSITION
HLLZ D,-3(FXP) ;FOR ITS, USE ↑P CODES TO SET
HRRI D,"V-10 ; CURSOR POSITION
PUSHJ P,RSTCU3
HRLZ D,-3(FXP)
HRRI D,"H-10
RSTCU3: ADD D,R70+10
JRST CNPCOD
] ;END OF IFN ITS
20$ HALT
20$ WARN [WHAT TO DO ABOUT RSTCUR?]
;;; ROUTINE WHICH ATTEMPTS TO RUB OUT A CHARACTER ON A TTY.
;;; SKIPS ON *FAILURE* TO RUB IT OUT.
;;; OUTPUT TTY FILE ARRAY MUST BE IN AR1.
RUB1C1: MOVEI TT,F.MODE
MOVE F,@TTSAR(AR1)
TLNE F,FBT<SE> ;IF CAN'T SELECTIVELY ERASE
TLNN F,FBT<CP> ; AND MOVE CURSOR AROUND FREELY,
JRST TYOFA ; MERELY ECHO RUBBED-OUT CHAR
IT% HALT
IFN ITS,[
CAIN A,177 ;RUBOUT DOESN'T PRINT, HENCE NEEDN'T KILL
POPJ P,
MOVEI T,1
CAILE A,↑← ;CHARS FROM 40 TO 176 ARE ONE
JRST RUB1C3 ; POSITION WIDE, SO BACK UP AND ERASE
CAIN A,↑I ;TABS ARE VARIABLE - MUST RETYPE
JRST POPJ1
CAIN A,↑J ;LINE FEED IS DOWNWARD MOTION -
JRST CNPU ; ERASE BY MOVING UP
CAIN A,↑H ;BACKSPACE IS ERASED BY
JRST CNPF ; MOVING FORWARD
CAIE A,↑M ;FOR CR, DON'T KNOW LENGTH OF PREVIOUS LINE
CAIN A,↑← ;FOR ↑←, MAY OR MAY NOT HAVE BEEN DOUBLED
JRST POPJ1
CAIE A,33 ;ALTMODE IS ALWAYS 1 WIDE
TLNE F,FBT<SA> ;OTHER CONTROLS ONE WIDE IF IN SAIL MODE
JRST RUB1C3
MOVEI T,2 ;OTHERWISE CONTROL CHARS ARE TWO WIDE
RUB1C3: MOVEI TT,F.CHAN
.CALL RCPOS
.VALUE
TLNE F,FBT<EC>
MOVE D,R
MOVEI R,(T)
CAILE T,(D)
PUSHJ P,CNPU
CAIE R,2
JRST CNPBL
JRST CNPBBL
] ;END OF IFN ITS
;%READLINE %RDLN5 %RDLN6 %RDLNZ
;;; READLINE TAKES STANDARD FILE/EOF INPUT ARGUMENTS AND READS
;;; ONE LINE FROM A FILE. IT INVOKES PRE-SCANNING FOR TTY'S.
;;; THE RESULT IS RETURNED AS AN ATOMIC SYMBOL, EXCLUDING THE
;;; CARRIAGE RETURN WHICH TERMINATES THE LINE. LINE FEEDS
;;; ARE IGNORED (NECESSARY FOR SUCCESSIVE READLINE'S).
%READLINE:
JSP D,INCALL
SFA% Q%READLINE
SFA$ [SO.RDL,,],,Q%READLINE
MOVEI A,Q%READLINE
HRLZM A,BFPRDP ;PERMIT TTY PRE-SCAN
MOVEI T,%RDLN5
PUSHJ FXP,MKNR6C ;PART OF MAKNAM
JRST PNGNK1 ;CREATE NON-INTERNED SYMBOL
%RDLN5: PUSH FXP,D
%RDLN6: PUSHJ P,@TYIMAN
IFN SAIL,[
ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER DOWN TO 7 BITS
TRZN TT,%TXCTL
JRST %RDLNZ
CAIE TT,177
TRZ TT,140
%RDLNZ:
] ;END IFN SAIL
CAIN TT,↑J ;IGNORE LINE FEEDS
JRST %RDLN6
POP FXP,D
CAIN TT,↑M ;CR TERMINATES
POPJ P,
MOVEI A,(TT)
JRST POPJ1
;
SUBTTL HAIRY READER BIT DESCRIPTIONS
;OBJECT FLAGS - AS AN OBJECT ACCUMULATES, THE LH OF ACC T
; HAS BITS SET TO DESCRIBE THE STATE OF THE OBJECT
;BIT VALUE MEANING
;3.1 1 TOP LEVEL OBJECT
;3.2 2 FIRST OBJECT OF A LIST
;3.3 4 DOTTED PAIR OBJECT - SECOND HALF
;3.4 10 DELAYED DOT READ
;3.5 20 ALPHA ATOM (I.E., NON-NUMBER ATOM)
;3.6 40 NUMBER ATOM
;3.7 100 DECIMAL NUMBER
;3.8 200 FLOATING NUMBER
;3.9 400 NEGATIVE NUMBER
;4.1 1000 EXPONENT-MODIFIED NUMBER, E.G. ↑ OR E (OR SPLICING, IF MACRO)
;4.2 2000 LSH-ED NUMBER, I.E. ←
;4.3 4000 LIST-TYPE OBJECT
;4.4 10000 SIGNED NUMBER ATOM, E.G. +A
;4.5 20000 MACRO-PRODUCED OBJECT
;4.6 40000 BIGNUM BASE 10.
;4.7 100000 BIGNUM BASE IBASE
;4.8 200000 HUNK
;CHARACTER FLAGS - THE RH OF AN ENTRY IN THE RCT TABLE
; GENERALLY HAS THE ASCII TRANSLATION FOR THE CHARACTER,
; EXCEPT MACRO-CHARACTERS, WHICH HOLD A FUNCTION TO EXECUTE
; THE LH HAS DESCRIPTOR BITS AS FOLLOWS:
;BIT VALUE MEANING
;3.1 1 ALPHABETIC, I.E. A,B,C,...,Z
;3.2 2 EXTENDED ALPHABETIC, E.G., !,",#,$, ETC. AND LOWERCASE
;3.3 4 DECIMAL DIGIT, I.E. 0,1,2,...,9
;3.4 10 + OR -
;3.5 20 ↑ OR ←
;3.6 40 SECOND CHOICE DENOTER FOR 3.4, 3.5, 4.1, AND 4.3
;3.7 100 PRINT SHOULD SLASHIFY IF NOT FIRST CHAR
;3.8 200 . <DECIMAL POINT> KIND OF DOT
;3.9 400 PRINT SHOULD SLASHIFY WHEN IN FIRST POSITION
;4.1 1000 THE RUBOUT CHARACTER, OR THE TTY FORCE FEED CHAR
;4.2 2000 THE READ "QUOTE" CHARACTER, I.E. /
;4.3 4000 MACRO CHARACTER, E.G. ', OR SPLICING MACRO
;4.4 10000 )
;4.5 20000 . <DOTTED-PAIR> KIND OF DOT
;4.6 40000 (
;4.7 100000 <SPACE> OR <TAB> OR <COMMA>
;4.8 200000 CHARACTER OBJECT
;4.9 400000 WORTHLESS CHARACTERS, AND ANY WITH BIT 3.8
; OR BITS 4.1-4.8 ON.
PGTOP RDR,[HIRSUTE READER, MAKNAM, ETC.]
;ARYTP1 NPARTP LARYTP ARYTYP ARYIN1 ARYIN2
;;@ END OF READER 196
;;@ ARRAY 85 ARRAY PACKAGE
;;; ***** MACLISP ****** ARRAY PACKAGE ***************************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT ARA
SUBTTL ARRAY PACKAGE
IFN SFA, QSFA
IFN JOBQIO, QJOB ;THESE ENTRIES USED ONLY
QFILE ; BY ARRAYDIMS FUNCTION
ARYTP1: AS.RDT+AS.FX,,QREADTABLE ;READTABLE
AS.OBA+AS.SX+AS.GCP,,QOBARRAY ;OBARRAY
NPARTP==.-ARYTP1 ;# OF PECULIAR ARRAY TYPES
DX$ AS.DX,,QDUPLEX ;DUPLEX
DX% -1
CX$ AS.CX,,QCOMPLEX ;COMPLEX
CX% -1
DB$ AS.DB,,QDOUBLE ;DOUBLE
DB% -1
AS.SX+AS.GCP,,TRUTH ;S-EXPRESSION
AS.FX,,QFIXNUM ;FIXNUM
AS.FL,,QFLONUM ;FLONUM
AS.SX,,NIL ;NSTORE-TYPE
LARYTP==.-ARYTP1
ARYTYP==ARYTP1-.LZ (AS.RDT), .SEE ADIMS ;FOR JFFO'S ON THE BITS
;;; TABLE OF EXTRA INSTRUCTIONS FOR ARRAY HEADER.
;;; ENTRIES ARE ZERO IF NO INSTRUCTION NEEDED.
;;; ENTRIES ARE NEGATIVE FOR AN ILLEGAL ARRAY TYPE.
;;; (NOTE THAT THE OPCODE PUSH IS POSITIVE.)
ARYIN1: 0 ;READTABLE
0 ;OBARRAY
TBLCHK ARYIN1,NPARTP
DX$ PUSH P,CDUPL1 ;DUPLEX
DX% -1
CX$ PUSH P,CCMPL1 ;COMPLEX
CX% -1
DB$ PUSH P,CDBL1 ;DOUBLE
DB% -1
0 ;S-EXPRESSION
PUSH P,CFIX1 ;FIXNUM
PUSH P,CFLOAT1 ;FLONUM
0 ;NSTORE-TYPE
TBLCHK ARYIN1,LARYTP
;;; <ADDRESS OF SUBSCRIPT INSTRUCTION TABLE>,,<MULTIPLIER>
;;; THE MULTIPLIER IS USED TO ADJUST FOR THE NUMBER OF WORDS
;;; OCCUPIED BY EACH ELEMENT.
ARYIN2: DIMFTB,,1 ;READTABLE
DIMSTB,,1 ;OBARRAY
TBLCHK ARYIN2,NPARTP
DX$ DIMZTB,,4 ;DUPLEX
DX% 0
CX$ DIMDTB,,2 ;COMPLEX
CX% 0
DB$ DIMDTB,,2 ;DOUBLE
DB% 0
DIMSTB,,1 ;S-EXPRESSION
DIMFTB,,1 ;FIXNUM
DIMFTB,,1 ;FLONUM
DIMSTB,,1 ;NSTORE-TYPE
TBLCHK ARYIN2,LARYTP
;DIMSTB DIMFTB DIMDTB DIMZTB
;;; TABLES OF INSTRUCTIONS FOR CALLING ARRAY SUBSCRIPT
;;; CALCULATION ROUTINES. DIMSTB IS FOR S-EXPRESSION
;;; ARRAYS, AND DIMFTB FOR FULL-WORD ARRAYS.
DIMSTB: JSP TT,1DIMS ;TABLE OF <N>DIMS'S
JSP TT,2DIMS
JSP TT,3DIMS
JSP TT,4DIMS
JSP TT,5DIMS
DIMFTB: JSP TT,1DIMF ;TABLE OF <N>DIMF'S
JSP TT,2DIMF
JSP TT,3DIMF
JSP TT,4DIMF
JSP TT,5DIMF
IFN DBFLAG+CXFLAG,[
DIMDTB: JSP TT,1DIMD
JSP TT,2DIMD
JSP TT,3DIMD
JSP TT,4DIMD
JSP TT,5DIMD
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
DIMZTB: JSP TT,1DIMZ
JSP TT,2DIMZ
JSP TT,3DIMZ
JSP TT,4DIMZ
JSP TT,5DIMZ
] ;END OF IFN DXFLAG
;TTDEAD TTDEDC ARRAY %%ARRAY ARRY0 ARRY0B ARRY0C ARRY0F ARRY0G ARRY1 ARRY1A
SUBTTL ARRAY AND *ARRAY FUNCTIONS
TTDEAD=BPURPG(TT)
TTDEDC=TTDEAD+<TTS<CN>,,>
ARRAY: JSP TT,FWNACK ;FSUBR
FA234567,,QARRAY
JSP TT,KLIST ;LIKE *ARRAY, BUT FIRST TWO
SUBI T,2 ; ARGS NOT EVALUATED
JRST ARRY0
%%ARRAY:
JSP TT,LWNACK ;LSUBR (2 . 7)
LA234567,,Q%%ARRAY
ARRY0: MOVEI TT,(P)
ADDI TT,(T) ;TT POINTS TO BELOW ARGS ON PDL
HRRZ A,2(TT)
ARRY0B: MOVSI F,-LARYTP ;CHECK OUT ARRAY TYPE
ARRY0C: HRRZ B,ARYTP1(F)
CAIN B,(A)
JRST ARRY0F
AOBJN F,ARRY0C
WTA [BAD ARRAY TYPE - *ARRAY!]
MOVEM A,2(TT)
JRST ARRY0B
ARRY0F: TLZ F,-1 ;F HAS ARRAY TYPE (INDEX INTO ARYTP1)
CAIL F,NPARTP ;SKIP IF PECULIAR ARRAY TYPE
JRST ARRY2
CAML T,XC-3
JRST ARRY1
ARRY0G: MOVEI D,Q%%ARRAY ;WRONG NUMBER OF ARGS - LOSEY LOSEY
JRST WNALOSE
ARRY1: HRRZ AR2A,ARRYQ1(F) ;DEFAULT ARRAY TO COPY FROM
CAML T,XC-2
SOJA T,ARRY1F ;T REFLECTS # OF DIMS
POP P,A ;GET THIRD ARG
ARRY1A: HLRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF NIL
JUMPE A,ARRY1F
HRRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF T
CAIN A,TRUTH
JRST ARRY1F
MOVEI C,(A) ;THIRD ARG BETTER BE AN ARRAY ITSELF
MOVEI D,(T)
PUSHJ P,AREGET ; TO COPY NEW ONE FROM
MOVEI T,(D)
HLLZ TT,ARRYQ1(F) ;SUPPLIED ARRAY BETTER BE
TDNE TT,ASAR(A) ; OF CORRECT TYPE
JRST ARRY1D
MOVEI A,(C)
%WTA ARRYQ0(F) ;IF NOT, LOSEY LOSEY
JRST ARRY1A
;ARRYQ0 ARRYQ1 ARRYQ2 ARRYQ3 ARRYQ4 ARRYQ5 ARRY1D ARRY1F ARRY2 ARRY2A ARRY2B
ARRYQ0: SIXBIT \NOT READTABLE - *ARRAY!\
SIXBIT \NOT OBARRAY - *ARRAY!\
ARRYQ1: AS.RDT,,VREADTABLE ;REQUIRED BIT,,NO ARG DEFAULT
AS.OBA,,VOBARRAY
ARRYQ2: VREADTABLE,,[PRDTBL]
VNIL,,VOBARRAY
ARRYQ3: 0,,2*LRCT ;MAX INDEX+1,,LENGTH OF DATA
OBTSIZ+1+200,,OBTSIZ+1+200 ;FOOEY - GLS
ARRYQ4: -1,,3 ;STANDARD GC AOBJN POINTER:
-<OBTSIZ+1>/2,,3 ; -<LENGTH IN WDS>,,<REL POS OF DATA>
ARRYQ5: RDTFIX ;FIXUP ROUTINE FOR AFTER BLT
OBAFIX
ARRY1D: SKIPA AR2A,A
ARRY1F: HRRZ AR2A,(AR2A) ;AR2A HAS SAR OF ARRAY TO COPY FROM
MOVNI AR1,2(T) ;AR1 HAS NUMBER OF DIMENSIONS
PUSH FXP,INHIBIT ;HALF A LOCKI
HRRZ R,ARRYQ3(F) ;R HAS LENGTH OF ARRAY DATA
HLRZ D,ARRYQ3(F) ;D HAS 1+LARGEST LEGAL INDEX
PUSH FXP,D
JRST ARRY2F
ARRY2: CAML T,XC-2 ;REGULAR ARRAY
JRST ARRY0G
PUSH FXP,INHIBIT ;HALF A LOCKI
MOVEI R,1 ;R ACCUMULATES SIZE OF DATA
HRREI D,2(T) ;-<# OF DIMENSIONS>
MOVNI AR1,2(T) ;AR1 GETS NUMBER OF DIMENSIONS
ARRY2A: POP P,A
ARRY2B: JSP T,FXNV1
TLNN TT,-1
JUMPG TT,ARRY2C
WTA [ILLEGAL DIMENSION - *ARRAY!]
JRST ARRY2B
;ARRY2C ARRYAE ARRY2F ARRY2H
ARRY2C: PUSH FXP,TT
IMULI R,(TT) ;PRODUCT OF ALL DIMENSIONS
AOJL D,ARRY2A
MOVEI D,(R) ;R HAS SIZE OF DATA, AR2A HAS NIL,
SETZ AR2A, ; D HAS 1+LARGEST LEGAL INDEX
HRRZ A,-1(P) ;PICK UP ARRAY NAME
ARRYAE: JUMPE A,ARRY2F ;ALWAYS ALLOW NIL
MOVEI TT,(A) ;GET POINTER TO ARRAY'S NAME ARG
LSH TT,-SEGLOG ;MAKE POINTER TO ST TABLE
MOVE TT,ST(TT) ;GET TABLE ENTRY
TLNE TT,SA\SY ;OK IF SAR OR SYMBOL
JRST ARRY2F ;WIN IF IT IS
%WTA NASER ;ELSE WRNG-TYPE-ARG ERROR
HRRZM A,-1(P) ;REPLACE RETURNED ARG
JRST ARRYAE ;AND TRY AGAIN WITH ATOM TEST
ARRY2F: SETOM INHIBIT ;OTHER HALF OF LOCKI
HRLM AR1,TOTSPC ;SAVE NUMBER OF DIMENSIONS
MOVEI T,(AR1) ;T ACCUMULATES SIZE OF HEADER
MOVEM D,LLIP1 ;SAVE 1+LARGEST LEGAL INDEX
MOVSI D,AS.SX
TDNN D,ARYTP1(F) ;S-EXP OR FULLWORD ARRAY?
AOJA T,ARRY2H ;FULLWORD NEEDS EXTRA WORD IN HEADER
ADDI R,1 ;S-EXP PACKS TWO ENTRIES PER WORD
LSH R,-1
ARRY2H: HRRZ TT,ARYIN2(F) ;ACCOUNT FOR LENGTHS OF ENTRIES
IMULI R,(TT)
MOVNM R,BPPNR ;-<SIZE OF ARRAY DATA IN WORDS>
ADDI T,2 ;TWO WDS IN HEADER FOR JSP AND SAR
HRLM T,BPPNR ;SAVE SIZE OF HEADER
ADDI R,1(T) ;ONE WORD FOR GC AOBJN POINTER
HRRM R,TOTSPC ;SAVE TOTAL SIZE OF ARRAY IN WORDS
MOVEM AR2A,(P) ;CLOBBER 2ND ARG WITH SAR OF ARRAY TO COPY
PUSH FXP,F ;SAVE ARRAY TYPE
;FALLS THROUGH
;ARRY3A ARRY6 ARRY6Q ARRY6A
;FALLS IN
SKIPN A,-1(P) ;ARRAY OF NIL GIVES A SAR
JRST ARRY3A ;DON'T DO SARGET FOR NIL
PUSHJ P,SARGET
JUMPN A,ARRY6 ;ALREADY HAS A SAR
ARRY3A: JSP T,SACONS
MOVEI B,(A)
MOVEI C,QARRAY
SKIPE A,-1(P)
PUSHJ P,PUTPROP ;AND PUTPROP IT UNLESS ATOM IS NIL
JUMPN A,ARRY6
MOVEM B,-1(P) ;WE WANT TO RETURN THE SAR, NOT NIL!
MOVEI A,(B)
ARRY6: MOVEM A,ADDSAR ;ADDRESS OF THE SAR
MOVEI B,ADEAD
MOVEM B,ASAR(A) ;THIS SAYS THE OLD ARRAY, IF ANY, IS DEAD
MOVE B,GCMKL
PUSHJ P,MEMQ1
JUMPE A,ARRY6Q
MOVEI B,DEDSAR
HRLM B,(A)
ARRY6Q: HRRZ TT,TOTSPC
MOVEM TT,GAMNT
MOVEI AR2A,GCMKL ;RUNNING BACKUP POINTER FOR GCMKL
MOVEI C,0 ;TAIL OF GAMKL FOR WINNING DEAD BLOCK
MOVEI F,-1 ;SIZE OF SMLST DEAD BLOCK NOT SMLR THAN REQUESTED
SKIPA D,BPSH ;RUNNING LOCATION OF BLOCK BEGINNINGS
ARRY6A: MOVE AR2A,AR1
HRRZ B,(AR2A)
JUMPE B,ARRY7 ;ALL DONE WITH GCMKL
HRRZ AR1,(B)
HLRZ A,(AR1)
MOVE TT,(A)
SUB D,TT
HLRZ A,(B)
HLRZ A,ASAR(A) ;ALIVEP
JUMPN A,ARRY6A
CAMGE TT,F
CAMGE TT,GAMNT
JRST ARRY6A
MOVE F,TT
MOVE C,AR2A
MOVE R,D
JRST ARRY6A
;ARRY7 ARRY7A ARRY7B ARRY4 ARRY5 ARRY5D ARRY5F ARRY5G ARRY8
ARRY7: JUMPN C,ARRY7A ;FOUND DEAD BLOCK BIG ENOUGH
HRRZ TT,TOTSPC ;ELSE MUST GRAB NEW BLOCK OF REQUISITE SIZE
PUSHJ P,AGTSPC
JUMPE A,ARRY8
SUB TT,TOTSPC
HRRZM TT,INSP
HRRZ TT,TOTSPC ;WILL MAKE AN ENTRY
JSP T,FIX1A ;ON GCMKL.
PUSHJ P,NCONS
MOVE B,ADDSAR
PUSHJ P,XCONS
MOVEI B,(A)
MOVEI A,GCMKL
PUSHJ P,.NCNC1
MOVE TT,INSP
JSP T,FIX1A
MOVEM A,VBPEND
JRST ARRY5
ARRY7A: HRRZ AR1,(C) ;C POINTS TO GCMKL TAIL WITH DEAD BLK TO BE USED
SUB F,GAMNT ;F HAD SIZE OF USEABLE DEAD BLK
JUMPN F,ARRY7B
MOVE B,ADDSAR ;DEAD BLOCK IS EXACTLY SIZE NEEDED
HRLM B,(AR1) ; SIMPLY SPLICE SAR INTO GCMKL AND XIT
JRST ARRY4
ARRY7B: ADD R,F ;SLICE UP DEAD BLOCK INTO ARRAY IN HIGHER
MOVEI A,DBM ; PART AND NEW DEAD BLK IN LOWER
HRLM A,(AR1)
MOVE TT,F
JSP T,FIX1A
HRRZ AR1,(AR1) ;INSTALL NEW DEAD BLOCK MARKER,
MOVEI AR2A,(A) ; AND NEW DEAD BLOCK SIZE
HRRZ TT,TOTSPC
JSP T,FIX1A
HRRZ B,(C)
PUSHJ P,CONS
MOVE B,ADDSAR
PUSHJ P,XCONS
HRLM AR2A,(AR1)
XCTPRO
HRRM A,(C) ;PROTECTED, JUST TO BE SAFE
NOPRO
ARRY4: HRRZM R,INSP ;R NOW HOLDS BEGINNING OF BLOCK FOR NEW ARRAY
ARRY5: POP FXP,F ;INDEX INTO ARYTP1
HRRZ R,INSP ;R HELPS PUSH OUT ARRAY HEADER
CAIGE F,NPARTP ;MAKE UP AOBJN POINTER FOR GC
SKIPA C,ARRYQ4(F)
MOVS C,BPPNR
ADDI C,2(R) ;ALLOW FOR SIZE OF HEADER, ETC.
PUSH R,C
SKIPGE ARYIN1(F) ;MAKE DOUBLY SURE ARRAY TYPE EXISTS
.VALUE
SKIPE TT,ARYIN1(F) ;OOPS! DO WE NEED EXTRA INSTRUCTION?
PUSH R,TT ;YES, PUSH IT OUT FIRST
HLRZ T,ARYIN2(F) ;BASE ADDRESS OF TABLE OF SUBSCRIPT FUNCTION CALLS
HLRZ D,TOTSPC ;NUMBER OF DIMENSIONS
ADDI T,-1(D)
PUSH R,(T) ;PUSH OUT JSP TO CORRECT PLACE
PUSH R,ADDSAR ;PUSH OUT ADDRESS OF SAR
ARRY5D: POP FXP,T ;PUSH OUT ARRAY DIMENSIONS, IN ORDER
PUSH R,T
SOJG D,ARRY5D
SETZM 1(R) ;ZERO FIRST WORD OF DATA
MOVSI A,1(R) ;MAKE UP BLT POINTER
HRRI A,2(R)
MOVN C,BPPNR
ADDI C,(R) ;C HAS LIMIT FOR BLT
POP P,AR1 ;DO WE WANT TO COPY ANOTHER ARRAY?
JUMPE AR1,ARRY5F ;NO - ZERO OUT ARRAY
HRL A,TTSAR(AR1) ;YES - REARRANGE BLT POINTER
SOJA A,ARRY5G
ARRY5F: TLZ C,-1 ;FOR ONE-WORD ARRAY, DON'T DO BLT!
CAIE C,-1(A)
ARRY5G: BLT A,(C)
MOVE AR2A,ADDSAR ;PUT CORRECT STUFF INTO SAR ITSELF
MOVE TT,INSP
ADDI TT,2
HLL TT,ARYTP1(F)
MOVEM TT,ASAR(AR2A)
ADDI R,1
HRRM R,TTSAR(AR2A)
HLRZ D,TOTSPC
DPB D,[TTSDIM,,TTSAR(AR2A)]
CAIGE F,NPARTP
PUSHJ P,@ARRYQ5(F) ;PECULIAR ARRAYS NEED FIXING UP
MOVE B,ADDSAR ;RETURN SAR IN B
POP P,A ;RETURN ARG 1 IN A
UNLKPOPJ
ARRY8: SUB P,R70+1
HLRZ TT,TOTSPC
MOVNI TT,1(TT)
HRLI TT,-1(TT)
ADD FXP,TT
HRRZ TT,TOTSPC
JSP T,FXCONS
PUSHJ P,NCONS
MOVEI B,Q%%ARRAY
PUSHJ P,NCONS
UNLOCKI
FAC [NO CORE - *ARRAY!]
;AREGET AREGT2 AREGT0 AREGT1
SUBTTL AREGET ROUTINE
AREGET: PUSH P,A ;GET AN ARRAY SAR (AND INSIST ON ONE!)
MOVEI TT,(A)
LSH TT,-SEGLOG
MOVE TT,ST(TT)
TLNE TT,SA
JRST AREGT0 ;A SAR ITSELF IS ACCEPTABLE
AREGT2: PUSHJ P,ARGET ;SO IS A SYMBOL WITH AN ARRAY PROPERTY
JUMPE A,AREGT1
AREGT0: MOVE TT,ASAR(A) ;A KILLED ARRAY IS AS BAD AS NO ARRAY
CAIE TT,ADEAD
JRST POP1J ;SUCCESS! RETURN THE SAR IN A
AREGT1: POP P,A ;FAILURE! CRAP OUT
WTA [NOT AN ARRAY!]
JRST AREGET
;MKFLAR MKFXAR MKDTAR MKLSAR MKAR1 SACONS ADIMS0 ADIMS ADIMS1
SUBTTL MKDTAR/MKLSAR ROUTINE, AND ARRAYDIMS FUNCTION
MKFLAR: SKIPA T,[QFLONUM]
MKFXAR: MOVEI T,QFIXNUM
JRST MKAR1
MKDTAR: TDZA T,T ;MAKE UP A DATA ARRAY [NO GC PROTECTION FOR ELTS]
MKLSAR: MOVEI T,TRUTH ;MAKE UP A LIST ARRAY [GC PROTECTION]
LSH TT,1 ;FINDS NUMBER OF DATA WORDS DESIRED IN TT
MKAR1: PUSH P,[PX1J] ;A CONTAINS NAME FOR ARRAY
PUSH P,A ;A=NIL => GENSYM A NAME
PUSH P,T ;A=<-1,,> => JUST RETURN THE SAR
PUSH FXP,TT ;LEAVES GENSYMMED NAME OF ARRAY IN A
MOVEI A,(FXP)
PUSH P,A ;LEAVES ADDRESS OF SAR IN B
MOVEI T,0
SKIPN A,-2(P)
PUSHJ P,GENSYM
HRRZM A,-2(P)
MOVNI T,3
JRST %%ARRAY
SPECPRO INTZAX
SACONS: SKIPN FFA ;SAR CONSER
PUSHJ P,AGC
MOVE A,@FFA
XCTPRO
EXCH A,FFA
NOPRO
HRLI T,((TT))
HLLM T,TTSAR(A)
JRST (T)
ADIMS0: MOVEI A,(C)
WTA [BAD ARG - ARRAYDIMS!]
ADIMS: MOVEI C,(A)
PUSHJ P,SARGET ;SUBR 1 - ARG MUST BE ARRAY
JUMPE A,ADIMS0
LOCKTOPOPJ
HRRZ T,ASAR(A) ;OKAY FOR ARRAY TO BE DEAD
CAIN T,ADEAD ; - GIVE OUT NIL
JRST FALSE
MOVEI C,(A)
MOVE T,ASAR(C)
JFFO T,.+1
HRRZ F,ARYTYP(TT) ;F HAS SYMBOL FOR ARRAY TYPE
LDB D,[TTSDIM,,TTSAR(C)]
MOVNI D,(D) ;D HAS -<# OF DIMS>
MOVNI R,1
TDZA B,B
ADIMS1: MOVEI B,(A) ;CONS UP LIST OF DIMENSIONS
MOVEI TT,(R)
MOVE TT,@TTSAR(C)
JSP T,FXCONS
PUSHJ P,CONS
CAME R,D
SOJA R,ADIMS1
MOVEI B,(F) ;CONS TYPE ON FRONT OF LIST
JRST XCONS
;BLTARRAY BLTAR1 BLTXIT BLTALZ BLTALS
SUBTTL BLTARRAY FUNCTION AND FRIENDS
BLTARRAY: EXCH A,B ;GRUMBLE! CALLED BY FILLARRAY
PUSH P,B
PUSHJ FXP,SAV5M3
PUSHJ P,AREGET
MOVEI AR1,(A)
HRRZ A,-2(P)
BLTAR1: PUSHJ P,AREGET
MOVEI AR2A,(A)
MOVE T,ASAR(AR1)
MOVE TT,ASAR(AR2A)
IFN JOBQIO,[
TLNE T,AS.JOB
JRST BLTALS
TLNE TT,AS.JOB
JRST BLTALZ
] ;END OF IFN JOBQIO
TLNE T,AS.FIL
JRST BLTI1
TLNE TT,AS.FIL
JRST BLTO1
LOCKI
PUSHJ P,.REA3
JRST BLTALZ ;ARRAY TYPES DON'T MATCH - LOSE LOSE
BLTXIT: PUSHJ FXP,RST5M3
UNLOCKI
JRST POPAJ
BLTALZ: UNLOCKI
MOVEI A,(AR2A)
WTA [BAD TARGET ARRAY TYPE - BLTARRAY!]
MOVEI AR2A,(A)
JRST BLTAR1
BLTALS: UNLOCKI
MOVEI A,(AR1)
WTA [BAD SOURCE ARRAY TYPE - BLTARRAY!]
MOVEI AR1,(A)
JRST BLTAR1
;.REA3 .REA3C .REA3D .REA3E C.REA2 ARYSIZ ARYSZ3 ARYSZ4 ARYSZ6 ARYSZ5 ARYSZ7
;;; SMASH ARRAY WHOSE SAR IS IN AR1 INTO ARRAY WHOSE SAR IS IN AR2A
;;; SKIPS ON SUCCESS - FAILS WHEN ARRAY TYPES DON'T MATCH
.REA3: HLLZ TT,ASAR(AR1)
HLLZ D,ASAR(AR2A)
XOR TT,D
TLZ TT,AS.GCP
JUMPE TT,.REA3C ;WIN IF ARRAY TYPES MATCH
TLNE TT,#<AS.DB+AS.CX+AS.DX+AS.FX+AS.FL> ;ASSUME WIN IF BOTH NUMERIC
POPJ P,
.REA3C: AOS (P)
MOVEI A,(AR1)
JSP T,ARYSIZ ;RETURNS SIZE IN WORDS IN TT
MOVE R,TT
MOVEI A,(AR2A)
JSP T,ARYSIZ
HRRZS (P)
CAMG TT,R ;MOVE NUMBER OF WORDS DICTATED
JRST .REA3D ; BY THE SMALLER OF THE ARRAYS
MOVE TT,R
HRROS (P) ;REMEMBER WHETHER ARRAY GETS BIGGER OR SMALLER
.REA3D: ADD TT,TTSAR(AR2A)
HRRZ R,TTSAR(AR2A)
HRL R,TTSAR(AR1)
BLT R,-1(TT) ;TRANSFER THE DATA
SKIPGE (P) ;IF DIDN'T SWITCH ARRAY SIZES THEN DO CHECK
JRST .REA3E
TLNE T,AS.SX ;IF S-EXP ARRAY
TRNN F,1 ;AND AN ODD NUMBER OF ENTRIES
SKIPA
HLLZS -1(TT) ;MAKE SURE LAST HALFWORD IS ZERO
.REA3E: TRNN D,AS.RDT+AS.OBA
C.REA2: POPJ P,.REA2
TRNN D,AS.RDT ;MUST PERFORM A SPECIAL FIXUP FOR
JRST OBAFX1 ; READTABLES AND OBARRAYS
JRST RDTFIX
;;; JSP T,ARYSIZ
;;; ACCEPTS A SAR IN A; RETURNS THE PRODUCT OF THE DIMENSIONS
;;; IN F, AND THE SIZE OF THE DATA IN WORDS IN TT.
;;; SAVES D AND R.
ARYSIZ: HLL T,ASAR(A) ;RETURN ADDRESS IN IN RH OF T
TLNE T,AS.RDT+AS.OBA
JRST ARYSZ5 ;SPECIAL HANDLING FOR READTABLES AND OBARRAY
LDB TT,[TTSDIM,,TTSAR(A)]
MOVNS TT
MOVE F,@TTSAR(A)
ARYSZ3: AOJE TT,ARYSZ4 ;ON EXIT, F HAS PRODUCT OF ALL DIMENSIONS
IMUL F,@TTSAR(A)
JRST ARYSZ3
ARYSZ4: TLNE T,AS.SX
JRST ARYSZ7
ARYSZ6: MOVE TT,F ;NUMERIC ARRAY - SIZES MAY BE 1, 2, 4
IFN DBFLAG+CXFLAG,[
TLNE T,AS.DB+AS.CX
LSH TT,1
] ;END OF IFN DBFLAG+CXFLAG
DX$ TLNE T,AS.DX
DX$ LSH TT,1
JRST (T)
ARYSZ5: MOVEI F,LRCT ;ASSUME A READTABLE
TLNE T,AS.RDT
JRST ARYSZ6
MOVEI F,OBTSIZ+1+200 ;IF NOT, AN OBARRAY
ARYSZ7: MOVEI TT,1(F) ;ALLOW FOR S-EXPRESSION ARRAYS
LSH TT,-1 ; HAVING TWO ELEMENTS/WORD
JRST (T)
;OBAFIX OBAFX1 OBAFX3 RDTFIX RDTFX2
OBAFIX: JUMPE AR1,CPOPJ ;FIX UP OBARRAY AFTER A BLTARRAY, ETC.
OBAFX1: MOVE T,TTSAR(AR2A) ; BY COPYING ALL THE BUCKETS
HRLI T,442200 ;USER INTERRUPTS SHOULD BE SHUT OFF
MOVEI D,OBTSIZ
OBAFX3: ILDB A,T
SETZ B,
PUSHJ P,.APPEND ;USE *APPEND TO COPY LISTS
DPB A,T
SOJG D,OBAFX3
POPJ P,
RDTFIX: SKIPA R,PROLIS ;FIX UP A READTABLE AFTER A BLTARRAY, ETC.
RDTFX2: HRRZ R,(R) ; BY DUPLICATING ALL PROLIS ENTRIES
JUMPE R,CPOPJ ; FOR MACRO CHAR FUNCTIONS
HLRZ D,(R)
HRRZ TT,(D)
HLRZ T,(TT)
CAIE T,(AR1)
JRST RDTFX2
HRRZ B,(TT)
MOVEI A,(AR2A)
PUSHJ P,CONS
HLRZ B,(D)
PUSHJ P,XCONS
MOVE B,PROLIS
PUSHJ P,CONS
MOVEM A,PROLIS
JRST RDTFX2
;BLTO1 BLTO3 BLTO4
;FILL OUTPUT FILE IN AR2A FROM ARRAY IN AR1.
BLTO1: TLNE T,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD
JRST BLTALS
EXCH AR1,AR2A
PUSHJ P,XOFLOK ;MAKE SURE TARGET ARRAY IS BINARY OUTPUT
IFN ITS,[
PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE D,TT ;MOVE INTO D
HRRZ T,TTSAR(AR2A)
HRLI T,444400 ;SET UP BYTE POINTER (BYTE = 36. BITS)
MOVE TT,TTSAR(AR1)
ADDM D,F.FPOS(TT)
.CALL SIOT ;TRANSFER DATA TO FILE
.LOSE 1400
JSP D,FORCE6 ;UPDATE FILE OBJECT VARIABLES
] ;END OF IFN ITS
IFN D20,[
PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
HRRZ 2,TTSAR(AR2A)
HRLI 2,440000 ;SET UP BYTE POINTER (BYTE = 36. BITS)
MOVN 3,TT ;NEGATIVE OF NUMBER OF BYTES
MOVE D,TT
MOVE TT,TTSAR(AR1)
HRRZ 1,F.JFN(TT) ;GET JFN FOR FILE
ADDM D,F.FPOS(TT)
SOUT ;TRANSFER DATA TO FILE
SETZB 2,3 ;FLUSH CRUD FROM AC'S
JSP T,FORCE6 ;UPDATE FILE OBJECT VARIABLES
] ;END OF IFN D20
IFN D10,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR I/O FILE
LSH B,27
TLO B,(OUT 0,) ;CONSTRUCT AN OUT INSTRUCTION
MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK
BLTO3: MOVE D,1(A) ;GET BYTE POINTER INTO BUFFER
ADDI D,1 ;ADDRESS OF FIRST FREE WORD IN BUFFER
HRLI D,(T) ;ADDRESS OF NEXT DATA WORD TO TRANSFER
SKIPN R,2(A) ;GET COUNT OF FREE BUFFER WORDS IN R
JRST BLTO4 ;OOPS, NONE - GO OUTPUT THIS BUFFER
CAILE R,(TT) ;IF REST OF DATA FITS IN BUFFER,
MOVEI R,(TT) ; TRANSFER NO MORE THAN NECESSARY
SUB TT,2(A) ;SUBTRACT FREE WORDS IN BUFFER FROM COUNT OF REMAINING DATA
MOVNS R
ADDM R,2(A) ;ADJUST BUFFER FREE COUNT FOR WORDS TRANSFERRED
MOVNS R
ADDB R,1(A) ;ADJUST BYTE POINTER, GET FINAL ADDRESS
BLT D,(R)
JUMPL TT,BLTXIT ;DIDN'T COMPLETELY FILL THIS LAST BUFFER, SO EXIT
BLTO4: XCT B ;OUTPUT THIS BUFFER
CAIA
HALT ;? THE OUTPUT LOST SOMEHOW
MOVE D,FB.BFL(F)
ADDM D,F.FPOS(F) ;UPDATE FILEPOS
JUMPG TT,BLTO3 ;GO AROUND AGAIN IF MORE DATA LEFT
] ;END OF IFN D10
JRST BLTXIT
;BLTI1 BLTI4 BLTI3 BLTI5 BLTI6 BLTI8
;FILL ARRAY IN AR2A FROM FILE IN AR1.
BLTI1: TLNE TT,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD
JRST BLTALZ
PUSHJ P,XIFLOK ;MAKE SURE SOURCE IS AN INPUT BINARY FILE
IFN ITS+D20,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
SKIPN R,FB.CNT(F) ;GET NUMBER OF DATA WORDS IN INPUT BUFFER
JRST BLTI4 ;NONE, GO DO DIRECT INPUT
CAILE R,(TT) ;TRANSFER NO MORE WORDS THAN
MOVEI R,(TT) ; THE TARGET ARRAY WILL HOLD
SUBI TT,(R) ;ADJUST COUNT FOR NUMBER OF WORDS TRANSFERRED
MOVN D,R
ADDM D,FB.CNT(F) ;ADJUST BYTE COUNT IN FILE OBJECT
IBP FB.BP(F) ;BYTE POINTER TO POINT TO FIRST BYTE WE WANT
MOVE D,FB.BP(F)
HRLI D,(D) ;ADDRESS OF FIRST WORD OF INPUT DATA
HRRI D,(T)
ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY
SUBI R,1 ;FOR CORRECT UPDATING, R IS 1 TOO BIG
ADDM R,FB.BP(F) ;UPDATE FILE BYTE POINTER
BLT D,-1(T) ;TRANSFER DATA
JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA
MOVE D,FB.BVC(F)
ADDM D,F.FPOS(F)
SETZM FB.BVC(F)
BLTI4:
IFN ITS,[
MOVE R,TT
MOVE D,TT ;GET COUNT OF BYTES
MOVE TT,F
HRLI T,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS)
.CALL SIOT ;INPUT MORE DATA
.LOSE 1400
SUB R,D
ADDM R,F.FPOS(TT) ;UPDATE THE FILE POSITION
JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA
] ;END OF IFN ITS
IFN D20,[
HRRZ 1,F.JFN(F) ;GET JFN FOR FILE
MOVEI 2,(T)
HRLI 2,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS)
MOVN 3,TT
SIN ;INPUT MORE DATA
ADD TT,3 ;NOT ADDI!!!
ADDM TT,F.FPOS(F) ;UPDATE THE FILE POSITION
MOVE D,3
SETZB 2,3 ;FLUSH JUNK FROM AC'S
JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA
] ;END OF IFN D20
] ;END OF IFN ITS+D20
IFN D10,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR FILE
LSH B,27
TLO B,(IN 0,) ;CONSTRUCT AN IN INSTRUCTION
MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK
BLTI3: SKIPN R,2(A) ;CHECK NUMBER OF WORDS IN THIS BUFFER
JRST BLTI5 ;NONE - GO READ SOME MORE
CAILE R,(TT) ;DON'T TRANSFER MORE WORDS
MOVEI R,(TT) ; THAN THE TARGET ARRAY NEEDS
SUBI TT,(R) ;ADJUST COUNT OF WORDS NEEDED
MOVN D,R
ADDM D,2(A) ;ADJUST COUNT IN BUFFER HEADER
MOVE D,1(A) ;GET BYTE POINTER TO INPUT BUFFER
HRLI D,1(D)
HRRI D,(T) ;FORM BLT POINTER
ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY
ADDM R,1(A) ;UPDATE INPUT BUFFER BYTE POINTER
BLT D,-1(T) ;TRANSFER DATA TO TARGET ARRAY
JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA
BLTI5: XCT B ;GET MORE DATA
JRST BLTI6 ;JUMP IF AN ERROR OCCURRED
MOVE D,FB.BFL(F)
ADDM D,F.FPOS(F) ;UPDATE FILE POSITION
JRST BLTI3
BLTI6: MOVE D,B ;CONSTRUCT A TEST FOR END OF FILE
XOR D,[<STATO 0,IO.EOF>#<IN 0,>]
XCT D
HALT ;LOSE TOTALLY IF NOT END OF FILE
] ;END OF IFN D10
HRRZ C,FI.EOF(TT) ;GET EOF FUNCTION FOR FILE
UNLOCKI
JUMPE C,BLTI8
MOVEI A,(AR1)
JCALLF 1,(C) ;CALL USER EOF FUNCTION
BLTI8: MOVEI A,(AR2A)
PUSHJ P,NCONS
MOVEI B,(AR1)
PUSHJ P,XCONS
MOVEI B,QFILLARRAY
PUSHJ P,XCONS
IOL [EOF - FILLARRAY!] ;ELSE GIVE IO-LOSSAGE ERROR
;.REARRAY .REA4B .REA4A .REA4 .REA5 .REA6 .REA6A .REA7 .REA7A .REA2 .REALOSE GETSP GETSP0 AGTSPC GETSP1 .REA1 .REA1A
SUBTTL *REARRAY FUNCTION
.REARRAY: ;THIS CODE COULD STAND MUCH IMPROVEMENT
JSP TT,LWNACK
LA1234567,,Q.REARRAY
AOJE T,.REA1 ;ONE ARG, DELETE THE ARRAY
MOVEI D,(P)
ADDI D,(T)
HRLI D,(T)
HRRZ A,(D)
SUBI T,1
PUSH FXP,T
.REA4B: PUSHJ P,AREGET
MOVE T,ASAR(A) ;GET SAR
TLNN T,AS.FIL\AS.JOB ;DON'T ALLOW JOB OR FILE ARRAY
JRST .REA4A
XCT .REA6A ;ISSUE WTA ERROR
JRST .REA4B
.REA4A: LOCKI
PUSH P,A
HLRZ T,ASAR(A)
HRRZ A,1(D)
.REA4: MOVSI F,-LARYTP
.REA5: HRRZ B,ARYTP1(F)
CAIN B,(A)
JRST .REA7
AOBJN F,.REA5
.REA6: UNLOCKI
POP FXP,T
.REA6A: WTA [BAD ARRAY TYPE - *REARRAY!]
MOVEM A,1(D)
PUSH FXP,T
LOCKI
JRST .REA4
.REA7: HLRZ TT,ARYTP1(F)
XORI TT,(T)
ANDCMI TT,AS<GCP>
JUMPN TT,.REA6
.REA7A: PUSH P,C.REA2
PUSH P,R70 ;*ARRAY WILL CREATE A FRESH SAR
PUSH P,1(D)
AOBJN D,.-1
UNLOCKI
MOVE T,(FXP)
JRST %%ARRAY
.REA2: LOCKI
HRRZ AR1,(P) ;AR1 HAS THE OLD ARRAY SAR
MOVEI AR2A,(A) ;AR2A HAS THE NEW ARRAY SAR
PUSHJ P,.REA3 ;COPY OLD ARRAY DATA INTO NEW ARRAY
JRST .REALOSE
MOVEI B,ADEAD ;NOW INTER-CLOBBER THE TWO SARS
EXCH B,ASAR(AR2A)
MOVEM B,ASAR(AR1) ;STORE NEW CONTENTS OF ASAR
TLNE B,AS<FX+FL>
ADDI B,1
MOVEM AR1,1(B) ;INSTALL CORRECT SAR IN ARRAY
MOVE B,TTSAR(AR2A)
HLLOS TTSAR(AR2A)
MOVEM B,TTSAR(AR1) ;STORE NEW CONTENTS OF TTSAR
MOVEI A,(AR1)
MOVE B,GCMKL
PUSHJ P,MEMQ1
JUMPE A,.REALOSE
MOVEI B,DEDSAR
HRLM B,(A)
MOVE B,GCMKL
MOVEI A,(AR2A)
PUSHJ P,MEMQ1
JUMPE A,.REALOSE
HRLM AR1,(A)
UNLOCKI
POP FXP,T
HRLI T,-1(T)
ADD P,T
JRST POPAJ
.REALOSE: SUB P,R70+1
UNLOCKI
POP FXP,T
PUSHJ FXP,LISTX
PUSHJ P,NCONS
MOVEI B,Q.REARRAY
PUSHJ P,XCONS
FAC [*REARRAY LOST!]
GETSP: JSP TT,LWNACK
LA12,,QGETSP
POP P,A
MOVEI D,GETSP1
HRL D,VPURE
AOJE T,GETSP0
HRLI D,(A)
POP P,A
GETSP0: JSP T,FXNV1 ;RETURNS BPEND-BPORG IF SPACE IS AVAILABLE
TLCE D,-1
TLZ D,-1
LOCKTOPOPJ
PUSH P,D
AGTSPC: MOVEM TT,GAMNT
ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT)
SUB TT,@VBPEND
JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE.
MOVE A,VBPEND ;ALREADY OK
MOVE TT,(A)
POPJ P,
GETSP1: JUMPE TT,FALSE
SUB TT,@VBPORG
JRST FIX1
.REA1: MOVE A,(P) ;REMOVES ARRAY BY PUTTING ADDRESS OF
PUSHJ P,SARGET ; ERROR ROUTINE IN SAR, ETC.
JUMPE A,POP1J
MOVE T,ASAR(A) ;GET SAR
TLNE T,AS.JOB\AS.FIL ;MUST NOT BE FILE OR JOB ARRAY
JRST .REA1A
MOVEI B,ADEAD
XCTPRO
MOVEM B,ASAR(A)
MOVE B,[TTDEAD]
MOVSI T,TTS<CN>
TDNE T,TTSAR(A)
IOR B,T
MOVEM B,TTSAR(A)
NOPRO
JRST POPAJ
.REA1A: POP P,A ;ARRAY IS FILE OR JOB OBJECT
XCT .REA6A ;ISSUE WTA ERROR
PUSH P,A
JRST .REA1
;AYNV1 AYNV5 AYNV4 AYNV3 AYNV2 AYNV0 AYNVER AYNVE1 2DIMS 2DIMS1 2DIMF 2DIMF1 2DIMD 2DIMD1 2DIMZ 2DIMZ1
SUBTTL MULTI-DIMENSIONAL ARRAY ACCESS ROUTINES
;;; THESE ARE LIKE THE FXNV ROUTINES; THEY TAKE A FIXNUM
;;; FROM AN ARGUMENT AC, CHECK ITS TYPE, AND PUT ITS VALUE
;;; IN R. THIS VALUE IS CHECKED TO ENSURE IT IS WITHIN THE
;;; NEXT DIMENSION VALUE. TT IS STEPPED ALONG THE VECTOR
;;; OF DIMENSIONS IN THE ARRAY HEADER. AYNV1 ADDITIONALLY
;;; PUTS THE ADDRESS OF THE SAR IN LISAR.
SFXPRO
AYNV1: HRRZ R,(TT)
MOVEM R,LISAR
AOJA TT,AYNV0
AYNV5: SKIPA A,AR2A
AYNV4: MOVEI A,(AR1)
JRST AYNV0
AYNV3: SKIPA A,C
AYNV2: MOVEI A,(B) ;LEFT HALF OF B MAY BE NON-ZERO
AYNV0: MOVEI R,(A)
LSH R,-SEGLOG
MOVE R,ST(R)
TLNN R,FX
JRST AYNVER ;LOSE IF NOT A FIXNUM
SKIPL R,(A) ;MUST NOT BE NEGATIVE,
CAML R,(TT) ; AND MUST BE BELOW NEXT DIMENSION
CAIA
AOJA TT,(T) ;RETURN TO CALLER, BUMPING POINTER IN TT
SKIPA D,[[SIXBIT \ARRAY SUBSCRIPT EXCEEDS BOUNDS!\]]
AYNVER: MOVEI D,[SIXBIT \NON-FIXNUM ARRAY SUBSCRIPT!\]
PUSH P,D
MOVEI R,(TT)
AYNVE1: HLRZ D,-1(R) ;WE MUST BACK UP THE POINTER TO THE JSP TT,
CAIE D,(JSP TT,) ; WHICH IS WHERE THE ASAR POINTS
SOJA R,AYNVE1
HRRZ D,(R)
SUB TT,ASAR(D) ;SAVE TT AS AN ABSOLUTE OFFSET FROM THE ASAR
EXCH D,(P) ; (SINCE DURING THE ERROR THE ARRAY MAY MOVE)
XCT AYNVSFX ;SYNCHRONIZE WITH THE INTERRUPT LOCKOUT MECHANISM
POP P,D
ADD TT,ASAR(D) ;RESTORE THE TT POINTER USING THE
JRST AYNV0 ; (POSSIBLY NEW) ASAR, AND TRY AGAIN
.SEE 1DIMS ;THE 1-DIMENSIONAL ACCESS ROUTINES ARE IN LOW CORE
2DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMS1: ADDI R,(F)
JRST ARYGET
2DIMF: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMF1: ADDI R,(F)
JRST ANYGET
IFN DBFLAG+CXFLAG,[
2DIMD: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMD1: ADDI R,(F)
JRST ADYGET
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
2DIMZ: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
2DIMZ1: ADDI R,(F)
JRST AZYGET
] ;END OF IFN DXFLAG
;3DIMF 3DIMS 3DIMX 4DIMF 4DIMS 5DIMF 5DIMS
;;; THERE ARE FOUR SEPARATE 1DIM- AND 2DIM- ROUTINES FOR SPEED.
;;; FOR THE OTHERS, WHICH ARE LESS COMMON, WE PREFER TO SAVE
;;; SPACE. WE ENCODE THE ARRAY TYPE IN THE LEFT HALF OF B:
;;; 0 S-EXPRESSION
;;; 1 FIXNUM, FLONUM
;;; 2 DOUBLE, COMPLEX
;;; 3 DUPLEX
;;; PLEASANTLY, IF THIS NUMBER IS N, AN ARRAY ELEMENT IS OF SIZE
;;; 2↑N HALFWORDS, BUT WE DO NOT USE THIS FACT.
IFN DXFLAG, 3DIMZ: TLOA B,2
IFN DBFLAG+CXFLAG, 3DIMD: TLOA B,2
3DIMF: TLO B,1
3DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
3DIMX: HLRZ T,B
TLZ B,-1
JRST .+1(T)
JRST 2DIMS1 ;S-EXPRESSION
JRST 2DIMF1 ;FIXNUM, FLONUM
IFN DBFLAG+CXFLAG, JRST 2DIMD1 ;DOUBLE, COMPLEX
.ELSE .VALUE
IFN DXFLAG, JRST 2DIMZ1 ;DUPLEX
.ELSE .VALUE
IFN DXFLAG, 4DIMZ: TLOA B,2
IFN DBFLAG+CXFLAG, 4DIMD: TLOA B,2
4DIMF: TLO B,1
4DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV4
JRST 3DIMX
IFN DXFLAG, 5DIMZ: TLOA B,2
IFN DBFLAG+CXFLAG, 5DIMD: TLOA B,2
5DIMF: TLO B,1
5DIMS: JSP T,AYNV1
MUL R,(TT)
JSP T,AYNV2
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV3
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV4
ADDI F,(R)
IMUL F,(TT)
JSP T,AYNV5
JRST 3DIMX
NOPRO
;FILLARRAY FILLA0 FILLA1 FILLA4 FILLA5 FILLA2 FILLA3 FILLD1 FILLD3 FILLD6 FILLZ1 FILLZ3 FILLZ6 OPNCLR FILLA6 FILLA9 FILLA8 FILLA7 FILLUZ
SUBTTL FILLARRAY AND LISTARRAY
FILLARRAY: ;SUBR 2
SKOTT B,LS
JRST BLTARRAY
MOVEI C,(B)
FILLA0: PUSH P,A
PUSHJ P,AREGET ;GET SAR OF ARRAY
HLLZ D,ASAR(A)
TLNE D,AS.JOB+AS.FIL+AS.RDT+AS.OBA
JRST FILLUZ ;CAN'T FILL JOB OR FILE OR READTABLE OR OBARRAY
JSP T,ARYSIZ ;GET SIZE OF ARRAY IN F
SETZ TT, ;TT WILL BE USED FOR INCREMENTAL INDEX
TLNN D,AS.SX
JRST FILLA2
FILLA1: JUMPE C,FILLA4 ;FILL LOOP FOR S-EXP ARRAYS
HLRZ B,(C)
HRLM B,@TTSAR(A)
HRRZ C,(C)
SOJE F,POPAJ
JUMPE C,FILLA5
HLRZ B,(C)
HRRM B,@TTSAR(A)
HRRZ C,(C)
SOJE F,POPAJ
AOJA TT,FILLA1
FILLA4: HRLM B,@TTSAR(A)
SOJE F,POPAJ
FILLA5: HRRM B,@TTSAR(A)
SOJE F,POPAJ
ADDI F,1
ROT F,-1 ;ROT, NOT LSH; SEE BELOW
MOVEI D,1 ;MULTIPLIER FOR ELEMENT SIZE
JRST FILLA7
FILLA2: TLNN D,AS.FX+AS.FL
IFN DBFLAG+CXFLAG, JRST FILLD1
.ELSE .VALUE
MOVEI B,(A) ;FILL LOOP FOR FULLWORD ARRAYS
FILLA3: JUMPE C,FILLA6
HLRZ A,(C)
HRRZ C,(C)
MOVEI R,(TT)
TLNN D,AS<FX>
JSP T,FLNV1X
JSP T,FXNV1
EXCH TT,R
MOVEM R,@TTSAR(B)
SOJE F,POPAJ
AOJA TT,FILLA3
IFN DBFLAG+CXFLAG,[
FILLD1: TLNN D,AS.DB+AS.CX
DX$ JRST FILLZ1
DX% .VALUE
MOVE F,D
FILLD3: JUMPE C,FILLD6 ;FILL LOOP FOR DOUBLE AND COMPLEX ARRAYS
HLRZ A,(C)
HRRZ C,(C)
MOVEI R,(TT)
DB$ CX$ TLNN F,AS.DB
DB$ CX$ JSP T,CXNV1X
DB$ JSP T,DBNV1
DB% JSP T,CXNV1
EXCH TT,R
MOVEM R,@TTSAR(B)
ADDI TT,1
MOVEM D,@TTSAR(B)
SOJE F,POPAJ
AOJA TT,FILLD3
FILLD6: ADDI TT,1
MOVEM D,@TTSAR(B)
MOVEI D,2
SOJA TT,FILLA9
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
FILLZ1: TLNN D,AS.DX
.VALUE
PUSH FXP,TT
PUSH FXP,F
FILLZ3: JUMPE C,FILLZ6 ;FILL LOOP FOR DUPLEX ARRAYS
HLRZ A,(C)
HRRZ C,(C)
JSP T,DXNV1
MOVE T,TT
MOVE TT,-1(FXP)
KA MOVEM R,@TTSAR(B)
KA ADDI TT,1
KA MOVEM F,@TTSAR(B)
KA ADDI TT,1
KIKL DMOVEM R,@TTSAR(B)
KIKL ADDI TT,2
MOVEM T,@TTSAR(B)
ADDI TT,1
MOVEM D,@TTSAR(B)
ADDI TT,1
MOVEM TT,-1(FXP)
SOSE (FXP)
JRST FILLZ3
POPI FXP,2
JRST POPAJ
FILLZ6:
KA MOVEM R,@TTSAR(B)
KA ADDI TT,1
KA MOVEM F,@TTSAR(B)
KA ADDI TT,1
KIKL DMOVEM R,@TTSAR(B)
KIKL ADDI TT,2
MOVEM T,@TTSAR(B)
ADDI TT,1
MOVEM D,@TTSAR(B)
SUBI TT,3
MOVEI D,4
JRST FILLA8
] ;END OF IFN DXFLAG
OPNCLR: MOVEI F,LONBFA ;USED BY $OPEN TO CLEAR ARRAY
SETZB TT,R ;SAR OF FILE ARRAY IS IN A
MOVEI B,(A)
PUSH P,A
FILLA6: MOVEI D,1
FILLA9: MOVEM R,@TTSAR(B)
FILLA8: SOJE F,POPAJ
TLO F,400000 ;AVOID HLLZS BELOW
MOVEI A,(B)
FILLA7: LOCKI ;IF LIST RUNS OUT, DUPLICATE INTO
ADD TT,TTSAR(A) ; REMAINING ELEMENTS WITH A BLT
IMULI F,(D) ;ACCOUNT FOR SIZE OF ELEMENTS
ADDI F,(TT)
ADDI F,-1(D)
HRLI TT,(TT)
ADDI TT,(D)
BLT TT,(F)
SKIPL F ;FOR AN ODD LENGTH S-EXP ARRAY, ZERO RH OF
HLLZS (F) ; LAST WORD SO GC WON'T MARK IT SPURIOUSLY
POP P,A
UNLKPOPJ
FILLUZ: POP P,A
WTA [CAN'T FILL THIS OBJECT WITH LIST - FILLARRAY!]
JRST FILLA0
;LISTARRAY LISTA3 LISTAZ LISTA7 LISTA1 LISTA2 LISTA5 LISTA6 LISJOB LISFIL LISTD5 LISTD6 LISTZ5 LISTZ6 LLDAT ILDAT LLDSTB LDAGEN LDPRLS LDDDTP LDBGEN LDNPDS
LISTARRAY:
JSP TT,LWNACK
LA12,,QLISTARRAY
HRLZI D,377777 ;INITIAL SETTING FOR COUNT
AOJE T,LISTA3
POP P,B ;COUNT INITIALIZED TO 2ND ARG IF PRESENT
JSP T,FXNV2
LISTA3: POP P,A
LISTAZ: PUSHJ P,AREGET
MOVE T,(A) ;GET SAR BITS
TLNE T,AS.JOB ;CAN'T BE JOB ARRAY
JRST LISJOB
TLNE T,AS.FIL ;OR FILE ARRAY
JRST LISFIL
JSP T,ARYSIZ ;GET SIZE OF ARRAY
JUMPL D,LISTA7 ;SET COUNT TO SIZE IF 2ND ARG NEGATIVE
CAMGE D,F ;OR IF 2ND ARG BIGGER THAN SIZE
MOVE F,D
LISTA7: MOVEI C,(A)
SETZB A,B
TLNN T,AS.SX
JRST LISTA5
MOVEI TT,-1(F)
LSHC TT,-1 ;FIGURE OUT IF ODD OR EVEN
JUMPGE D,LISTA2 ; NUMBER OF ITEMS TO LIST
LISTA1: HRRZ B,@TTSAR(C) ;S-EXP ARRAY LISTING LOOP
PUSHJ P,XCONS
LISTA2: HLRZ B,@TTSAR(C)
PUSHJ P,XCONS
SOJGE TT,LISTA1
POPJ P,
LISTA5: TLNN T,AS.FX+AS.FL
IFN DBFLAG+CXFLAG, JRST LISTD5
.ELSE .VALUE
SKIPA D,T ;FULLWORD ARRAY LISTING LOOP
LISTA6: MOVEI B,(A)
MOVEI TT,-1(F)
MOVE TT,@TTSAR(C)
TLNN D,AS<FX> ;CONS UP FLONUM OR FIXNUM?
JSP T,FLCONX ;FLONUM CONS WITH SKIP RETURN
JSP T,FXCONS ;FIXNUM CONS
PUSHJ P,CONS
SOJG F,LISTA6
POPJ P,
LISJOB: WTA [JOB ARRAY ILLEGAL - LISTARRAY!]
JRST LISTAZ
LISFIL: WTA [FILE ARRAY ILLEGAL - LISTARRAY!]
JRST LISTAZ
IFN DBFLAG+CXFLAG,[
LISTD5: TLNN T,AS.DB+AS.CX
DX$ JRST LISTZ5
DX% .VALUE
SKIPA R,T
LISTD6: MOVEI B,(A) ;DOUBLE/COMPLEX ARRAY LISTING LOOP
KA HRROI TT,-1(F)
KA ROT TT,1 ;SNEAKY, HUH?
KA MOVE D,@TTSAR(C)
KA SUBI TT,1
KA MOVE TT,@TTSAR(C)
KIKL MOVEI TT,-1(F)
KIKL LSH TT,1
KIKL DMOVE TT,@TTSAR(C)
DB$ CX$ TLNN R,AS.DB
DB$ CX$ JSP T,CXCONX ;COMPLEX CONS WITH SKIP RETURN
DB$ JSP T,DBCONS
DB% JSP T,CXCONS
PUSHJ P,CONS
SOJG F,LISTD5
POPJ P,
] ;END OF IFN DBFLAG+CXFLAG
IFN DXFLAG,[
LISTZ5: TLNN T,AS.DX
.VALUE
PUSH FXP,F
SKIPA TT,F
LISTZ6: MOVEI B,(A)
LSH TT,2
KA MOVE R,@TTSAR(C)
KA ADDI TT,1
KA MOVE F,@TTSAR(C)
KA ADDI TT,2
KA MOVE D,@TTSAR(C)
KA SUBI TT,1
KA MOVE TT,@TTSAR(C)
KIKL DMOVE R,@TTSAR(C)
KIKL ADDI TT,2
KIKL DMOVE TT,@TTSAR(C)
JSP T,DXCONS
PUSHJ P,CONS
SOSE TT,(FXP)
JRST LISTZ6
POPI FXP,1
POPJ P,
] ;END OF IFN DXFLAG
PGTOP ARA,[ARRAY STUFF]
;;@ END OF ARRAY 85
;;@ FASLOA 223 FASLOAD
;;; **************************************************************
;;; ***** MACLISP ****** FASLOAD ********************************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT FSL
SUBTTL HAIRY RELOCATING LOADER (FASLOAD)
;;; BUFFER PARAMETERS
LLDAT==:770 ;LENGTH OF LOADER'S ATOMTABLE ARRAY
ILDAT==:1000 ;AMOUNT TO INCREMENT ATOMTABLE ARRAY
LLDSTB==:400 ;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES)
;;; PDL OFFSETS
LDAGEN==:0 ;SAR FOR ATOMTABLE
LDPRLS==:-1 ;PURE CLOBBERING LIST
LDDDTP==:-2 ;DDT FLAG
LDBGEN==:-3 ;SAR FOR I/O BUFFER
LDNPDS==:4 ;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES
;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING
;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH
;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED
;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE. THE
;;; ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS FOR NIL;
;;; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH ATOMTABLE
;;; ENTRY IS AS FOLLOWS:
;;; 4.9-4.1 IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY
;;; (4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE
;;; CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS
;;; BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777.
;;; NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE
;;; HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO.
;;; 3.4 THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED
;;; FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED
;;; BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS
;;; IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE
;;; IN THE GC PROTECTION ARRAY (SEE GCPRO).
;;; 3.3-3.2 INDICATES THE TYPE OF ATOM: 0 => SYMBOL,
;;; 1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM.
;;; 3.1 THIS BIT IS TURNED ON IF THE ATOM IS EVER
;;; REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED
;;; CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES).
;;; IT INDICATES THAT THE ATOM MUST SOMEHOW BE
;;; PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR.
;;; 2.9-1.1 CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!)
;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL
;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE
;;; RETRIEVED EXTREMELY QUICKLY.
;
;;; FORMAT OF FASL FILES:
;;;
;;; THE "NEW" FASLOAD SCHEME (AS OF 1/31/73) USES A NEW FORMAT FOR
;;; ITS FILES. A FASL FILE CONSISTS OF TWO HEADER WORDS, FOLLOWED BY
;;; A SERIES OF FASL BLOCKS; THE TWO HEADER WORDS ARE BOTH SIXBIT,
;;; THE FIRST BEING "*FASL+" (FOR HISTORICAL REASONS, "*FASL* IS
;;; ALSO ACCEPTED) AND THE SECOND THE CONTENTS OF LOCATION LDFNM2 IN
;;; THE LISP WHICH ASSEMBLED THE FILE (A VERSION NUMBER IN SIXBIT).
;;; EACH FASL BLOCK CONSISTS OF A WORD OF NINE FOUR-BIT RELOCATION
;;; BYTES, FOLLOWED BY NINE PIECES OF FASL DATA. THE LENGTH OF EACH
;;; DATA ITEM IS DEPENDENT ON THE RELOCATION TYPE; THUS FASLBLOCKS
;;; ARE OF VARYING LENGTH. THE LAST BLOCK MAY HAVE FEWER THAN NINE
;;; DATA ITEMS. THE RELOCATION TYPES AND THE FORMATS OF THE
;;; ASSOCIATED DATA ITEMS ARE AS FOLLOWS:
;;;
;;; TYPE 0 ABSOLUTE
;;; ONE ABSOLUTE WORD TO BE LOADED.
;;;
;;; TYPE 1 RELOCATABLE
;;; ONE WORD, THE RIGHT HALF OF WHICH IS RELOCATABLE; I.E. AT LOAD
;;; TIME THE LOAD OFFSET IS TO BE ADDED TO THE RIGHT HALF.
;;;
;;; TYPE 2 SPECIAL
;;; A WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM (HOPEFULLY OF TYPE PNAME) THE ADDRESS OF THE VALUE CELL OF
;;; WHICH IS TO REPLACE THE RIGHT HALF OF THE LOADED WORD. (IF NO
;;; VALUE CELL EXISTS, ONE IS TO BE CREATED.)
;;;
;;; TYPE 3 SMASHABLE CALL
;;; SIMILAR TO TYPE 4 (Q.V.) EXCEPT THAT THE INSTRUCTION IS ONE OF
;;; THE SERIES OF CALL UUOS WHICH MAY BE "SMASHED" FOR PURIFICATION
;;; PURPOSES. AT PRESENT THESE UUOS ARE: CALL, JCALL, NCALL, NJCALL.
;;;
;;; TYPE 4 QUOTED ATOM
;;; ONE WORD TO BE LOADED WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM WHOSE ADDRESS IS TO REPLACE THE RIGHT HALF OF THE WORD
;;; LOADED.
;;;
;;; TYPE 5 QUOTED LIST
;;; A SERIES OF WORDS REPRESENTING AN S-EXPRESSION TO BE CONSTRUCTED
;;; BY THE LOADER. THE FORMAT OF THESE WORDS IS BEST EXPLAINED BY
;;; THE ALGORITHM USED TO CONTRUCT THE S-EXPRESSION: THE LOADER
;;; EXAMINES BITS 4.7-4.9 OF SUCCESSIVELY READ WORDS, AND DISPATCHES
;;; ON THEM:
;;; 0 THE ATOM WHOSE INDEX IS IN THE RIGHT HALF OF THE WORD
;;; IS PUSHED ONTO A STACK.
;;; 1 THE LOADER POPS AS MANY ITEMS OFF THE STACK AS
;;; SPECIFIED BY THE NUMBER IN THE RIGHT HALF OF THE WORD
;;; AND MAKES A LIST OF THEM, SO THAT THE LAST ITEM POPPED
;;; BECOMES THE FIRST ITEM OF THE LIST; THIS LIST IS THEN
;;; PUSHED ONTO THE STACK.
;;; 2 THE LOADER POPS ONE ITEM OFF THE STACK AND PROCEEDS AS
;;; FOR 1, EXCEPT THAT THE ITEM FIRST POPPED IS USED TO
;;; END THE LIST INSTEAD IF NIL. (THIS ALLOWS FOR DOTTED
;;; PAIRS.)
;;; 3 THE TOP ITEM ON THE STACK IS EVALUATED AND STORED BACK
;;; ON THE TOP OF THE STACK.
;;; 4 THE RIGHT HALF OR THE WORD SPECIFIES THE LENGTH OF A
;;; HUNK TO BE MADE BY TAKING THAT MANY ITEMS FROM THE TOP
;;; OF THE STACK; THIS HUNK IS THEN PUSHED BACK.
;;; 5 UNUSED.
;;; 6 UNUSED.
;;; 7 THE LEFT HALF OF THE WORD SHOULD BE -1 OR -2,
;;; INDICATING THE SECOND LAST WORD OF THE DATA; IF -1,
;;; THE RIGHT HALF OF THIS WORD AND THE ADDRESS OF (WHAT
;;; SHOULD BE) THE SINGLE ITEM ON THE STACK (WHICH IS
;;; POPPED OFF) ARE MADE RESPECTIVELY INTO THE LEFT AND
;;; RIGHT HALVES OF A WORD TO BE LOADED INTO BINARY
;;; PROGRAM SPACE; IF -2, THE S-EXPRESSION IS PLACED INTO
;;; THE NEXT SLOT OF THE ATOMTABLE (SEE TYPE 12). THE ONE
;;; WORD REMAINING IS THE HASH KEY OF THE S-EXPRESSION AS
;;; COMPUTED BY SXHASH; THIS IS USED BY THE LOADER TO SAVE
;;; GCPRO SOME WORK.
;;;
;;; TYPE 6 GLOBALSYM
;;; ONE WORD; THE RIGHT HALF IS AN INDEX INTO THE TABLE LSYMS IN
;;; LISP. THE INDICATED VALUE IS RETRIEVED, NEGATED IF BIT 4.9 OF
;;; THE DATA WORD IS 1, AND ADDED TO THE RIGHT HALF OF THE LAST
;;; WORD LOADED INTO BINARY PROGRAM SPACE. THIS ALLOWS LAP CODE
;;; TO REFER TO SELECTED LOCATIONS INTERNAL TO LISP WITHOUT
;;; GETTING SYMBOLS FROM DDT.
;;;
;;; TYPE 7 GETDDTSYM
;;; IF THE FIRST WORD IS -1, THEN THE LOAD OFFSET IF ADDED INTO
;;; THE LEFT HALF OF THE WORD MOST RECENTLY LOADED INTO BINARY
;;; PROGRAM SPACE (THIS IS HOW LEFT HALF RELOCATION IS
;;; ACCOMPLISHED). OTHERWISE, THE FIRST WORD CONTAINS IN BITS
;;; 1.1-4.5 A SYMBOL IN SQUOZE CODE. THE LOADER GETS THE VALUE OF
;;; THIS SYMBOL FROM DDT IF POSSIBLE, NEGATES IT IF BIT 4.9 IS 1,
;;; THEN ADDS THE RESULT TO THE FIELD OF THE LAST WORD LOADED AS
;;; SPECIFIED BY BITS 4.6-4.7:
;;; 3 = ENTIRE WORD
;;; 2 = AC FIELD ONLY
;;; 1 = RIGHT HALF ONLY
;;; 0 = ENTIRE WORD, BUT SWAP HALVES OF VALUE BEFORE ADDING.
;;; THESE FOUR FIELDS CORRESPOND TO OPCODE, AC, ADDRESS, AND INDEX
;;; FIELDS RESPECTIVELY IN A LAP INSTRUCTION. IF BIT 4.8 IS A 1,
;;; THEN ANOTHER WORD FOLLOWS, CONTAINING THE VALUE OF THE SYMBOL
;;; AS OBTAINED FROM DDT AT ASSEMBLE TIME. IF THE VERSION NUMBER
;;; OF THAT LISP (AS DETERMINED FROM THE SECOND FILE HEADER WORD)
;;; IS THE SAME AS THAT OF THE LISP BEING LOADED INTO, THEN THIS
;;; VALUE IS USED AND DDT IS NOT CONSULTED AT LOAD TIME; THIS IS
;;; FOR SPEED. IF THE VERSION NUMBERS ARE DIFFERENT, THEN DDT IS
;;; CONSULTED.
;;;
;;; TYPE 10 ARRAY REFERENCE
;;; ONE WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE ATOMINDEX
;;; OF AN ATOMIC SYMBOL. IF THE SYMBOL HAS AN ARRAY PROPERTY, IT
;;; IS FETCHED; OTHERWISE ONE IS CREATED. THE RIGHT HALF OF THE
;;; WORD TO BE LOADED IS REPLACED WITH THE ADDRESS OF THE SECOND
;;; WORD OF THE ARRAY POINTER (I.E. OF THE TTSAR). IN THIS WAY
;;; ACCESSES TO ARRAYS CAN BE OPEN-CODED.
;;;
;;; TYPE 11 UNUSED
;;;
;;; TYPE 12 ATOMTABLE INFO
;;; A HEADER WORD, POSSIBLY FOLLOWED BY OTHERS, DEPENDING ON BITS
;;; 4.7-4.9:
;;; 0 THE RIGHT HALF IS THE NUMBER OF WORDS FOLLOWING, WHICH
;;; CONSTITUTE THE PNAME OF A PNAME-TYPE ATOM, IN THE
;;; ORDER OF THEIR APPEARANCE ON A PROPERTY LIST. THE ATOM
;;; IS INTERNED.
;;; 1 THE ONE WORD FOLLOWING IS THE VALUE OF A FIXNUM TO BE
;;; CREATED.
;;; 2 THE FOLLOWING WORD IS THE VALUE OF A FLONUM.
;;; 3 THE RIGHT HALF IS THE NUMBER OF FIXNUM COMPONENTS OF A
;;; BIGNUM FOLLOWING, MOST SIGNIFICANT WORD FIRST. BIT 3.1
;;; IS THE SIGN OF THE BIGNUM.
;;; 4 THE FOLLOWING TWO WORDS ARE A DOUBLE-PRECISION NUMBER.
;;; 5 THE FOLLOWING TWO WORDS ARE A COMPLEX NUMBER.
;;; 6 THE FOLLOWING FOUR WORDS ARE A DUPLEX NUMBER.
;;; 7 UNUSED.
;;; THE ATOM THUS CREATED IS ASSIGNED A PLACE IN THE ATOMTABLE
;;; MAINTAINED BY THE LOADER (AS AN ARRAY) USING CONSECUTIVE
;;; LOCATIONS; FROM THAT POINT ON OTHER DATA ITEMS REFERRING TO
;;; THAT ITEM CAN DO SO BY THE INDEX OF THE ATOM IN THIS TABLE.
;;; SEE ALSO TYPES 5 AND 16, WHICH ALSO MAKE ENTRIES IN THE
;;; ATOMTABLE.
;;;
;;; TYPE 13 ENTRY INFO
;;; TWO WORDS. THE LEFT HALF OF THE FIRST WORD IS THE ATOMINDEX
;;; OF THE NAME OF THE FUNCTION BEING DEFINED; THE RIGHT HALF
;;; THAT OF THE SUBR TYPE (THE PROPERTY UNDER WHICH TO CREATE THE
;;; ENTRY POINT, E.G. SUBR OR FSUBR). THE RIGHT HALF OF THE
;;; SECOND WORD IS THE LOCATION OF THE ENTRY POINT AS A
;;; RELOCATABLE POINTER: THE LOAD OFFSET MUST BE ADDED TO IT. THE
;;; LEFT HALF OF THE SECOND WORD CONTAINS THE ARGS PROPERTY, IN
;;; INTERNAL ARGS PROPERTY FORMAT, AS SPECIFIED IN THE ORIGINAL
;;; LAP CODE BY THE ARGS CONSTRUCT.
;;;
;;; TYPE 14 LOC
;;; THE WORD IS A RELOCATABLE QUANTITY SPECIFYING WHERE TO
;;; CONTINUE LOADING. IT IS NOT PERMITTED TO LOC BELOW THE
;;; ORIGIN OF THE ASSEMBLY. IF THE LOC IS TO A LOCATION HIGHER
;;; THAN ANY YET LOADED INTO, THEN FASLOAD ZEROS OUT ALL WORDS
;;; ABOVE THAT HIGHEST LOCATION UP TO THE LOCATION SPECIFIED.
;;; FASLOAD KEEPS TRACK OF THE HIGHEST LOCATION EVER LOADED INTO;
;;; THIS VALUE PLUS ONE BECOMES THE VALUE OF BPORG AT THE END OF
;;; ASSEMBLY, REGARDLESS OF THE STATE OF THE LOCATION POINTER
;;; WHEN LOADING TERMINATES. THIS TYPE IS NEVER USED BY LAP
;;; CODE, BUT ONLY BY MIDAS .FASL CODE.
;;;
;;; TYPE 15 PUTDDTSYM
;;; FIRST WORD, THE SYMBOL IN SQUOZE CODE. IF BIT 4.9=0, THE
;;; SYMBOL IS DEFINED TO DDT IF POSSIBLE WITH THE ADDRESS OF THE
;;; WORD OF BINARY PROGRAM SPACE ABOUT TO BE LOADED INTO AS ITS
;;; VALUE. IF BIT 4.9=1, THE VALUE IS GOBBLED FROM THE FOLLOWING
;;; WORD. BIT 4.8 (OF THE WORD CONTAINING THE SQUOZE) MEANS
;;; RELOCATE THE LEFT HALF OF THE VALUE BY THE LOAD OFFSET, AND
;;; BIT 4.7 LIKEWISE FOR THE RIGHT HALF. WHETHER OR NOT THE
;;; SYMBOL ACTUALLY GETS PUT IN DDT'S SYMBOL TABLE IS A FUNCTION
;;; OF THREE CONDITIONS: FIRST, THAT THERE IS A DDT WITH A SYMBOL
;;; TABLE; SECOND, THE VALUE OF THE LISP VARIABLE "SYMBOLS";
;;; THIRD, BIT 4.6 OF THE FIRST PUTDDTSYM WORD. THE FIRST
;;; CONDITION OF COURSE MUST BE SATISFIED. IF SO, THEN THE SYMBOL
;;; IS PUT IN THE SYMBOL TABLE ONLY IF SYMBOLS HAS A NON-NIL
;;; VALUE. FURTHERMORE, IF THAT VALUE IS THE ATOM SYMBOLS ITSELF,
;;; THEN THE SYMBOL IS PUT ONLY IF BIT 4.6 IS ON (INDICATING A
;;; "GLOBAL" SYMBOL).
;;;
;;; TYPE 16 EVAL MUNGEABLE
;;; A SERIES OF WORDS SIMILAR TO THOSE FOR TYPE 5, BUT WITH NO
;;; FOLLOWING HASH KEY. AN S-EXPRESSION IS CONSTRUCTED AND
;;; EVALUATED. THIS IS USED FOR THE SO-CALLED "MUNGEABLES" IN A
;;; FILE OF LAP CODE. IF THE LEFT HALF OF THE LAST WORD IS -1,
;;; THE VALUE IS THROWN AWAY. IF IT IS -2, THE VALUE IS ENTERED
;;; IN THE ATOMTABLE.
;;;
;;; TYPE 17 END OF BINARY
;;; ONE WORD, WHICH MUST BE "*FASL+" (OR "*FASL*") IN SIXBIT.
;;; THIS SHOULD BE THE LAST DATA WORD IN THE FILE. ANY RELOCATION
;;; BYTES LEFT OVER AFTER A TYPE 17 ARE IGNORED. THIS SHOULD BE
;;; FOLLOWED EITHER BY END OF FILE OR A WORD FULL OF ↑C'S.
;IALB
;;; INTERNAL AUTOLOAD ROUTINE
IALB: HRRZ AR2A,VDEFAULTF ;SUBR 1
JSP T,SPECBIND
0 AR2A,VDEFAULTF
HRRZ A,(A)
MOVEI B,QA%DDD
PUSHJ P,MERGEF
PUSHJ P,LOAD
JRST UNBIND
;FASLOAD LDXXY1
FASLOAD:
JSP TT,FWNACK
FA01234,,QFASLOAD
SKIPE FASLP
JRST LDALREADY
PUSH P,FLP ;FOR DEBUGGING PURPOSES
PUSH P,FXP .SEE LDEOMM
PUSH P,SP
10$ SETOM LDEOFP ;FLAG FOR CRUFTY D10 DUMP MODE I/O EOF
PUSHJ P,FIL6BT
MOVSI T,(SIXBIT \*\)
IT$ MOVE TT,[SIXBIT \FASL\] ;DEFAULT SECOND FILE NAME IS "FASL"
10$ MOVSI TT,(SIXBIT \FAS\) ;DEFAULT FILE NAME EXTENSION IS "FAS"
20$ MOVE TT,[ASCII \FASL\]
20% CAMN T,(FXP)
20% MOVEM TT,(FXP)
20$ SKIPE -L.6VRS-L.6EXT+1(FXP) ;EXTENSION NULL?
20$ CAMN T,-L.6VRS-L.6EXT+1(FXP) ;OR EQUAL TO *?
20$ MOVEM TT,-L.6VRS-L.6EXT+1(FXP) ;EITHER, USE FASL
PUSHJ P,DMRGF
PUSHJ P,6BTNML
MOVEI B,TRUTH
JSP T,SPECBIND
0 A,LDFNAM ;MUST BIND LDFNAM FOR RECURSIVE FASLOADING
0 B,VNORET
FASLP
PUSH P,[LDXXY1]
PUSH P,A
PUSH P,[QFIXNUM]
MOVNI T,2
JRST $OPEN
LDXXY1: MOVEM A,FASLP
PUSH P,A
HRRZM A,LDBSAR
MOVE A,LDFNAM
PUSHJ P,DEFAULTF
SETZM LDTEMP ;CROCK!
;FALLS THROUGH
;LDDISM LDRTHS LDXQQ5 LDXQQ2 LDXQQ3 LDXQQ6 LDXQQ8 LDXQQ7
;FALLS IN
;;; COME HERE TO "DO IT SOME MORE"
LDDISM: PUSHJ P,LDGDDT ;SET UP DDT FLAG: 0 => NO DDT;
PUSH P,TT ;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS
;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY
; (SEE LDPUT)
SKIPN F,VPURE ;SET UP CALL PURIFY FLAGS:
;400000,,XXX => NO PURIFY HACKERY
TLOA F,400000 ;200000,,XXX => SUBST XCTS FOR CALLS,
; PUT CALLS IN SEPARATE PAGES
;100000 BIT MEANS FASLOAD INTO HISEG (D10 ONLY)
HRRZ F,VPURCLOBRL ;0,,<PURE LIST> => SUBST PUSHJS AND
; JRSTS FOR CALLS
PUSH P,F ; ANY CALLS NOT IMMEDIATELY SMASHABLE
MOVE A,VPURE ; ARE CONSED ONTO THE PURE LIST
PUSHJ P,FIXP ;LEAVES VALUE IN TT IF INDEED FIXNUM
JUMPE A,LDXXX1
MOVSI F,200000
IORM F,(P)
IFN <PAGING-1>*HISEGMENT,[
JUMPGE TT,LDXQQ7 ;IF PURE IS A NEGATIVE FIXNUM, DO HISEG HACKERY
SA% HRROI T,.GTSGN ;FIND WHETHER HISEG SHARABLE (FROM
SA% GETTAB T, ;6.03 MONITOR CALLS)
SA% .VALUE
SA% TLNN T,(SN%SHR)
SA$ SKIPL .JBHRL ;IS HISEG CURRENTLY WRITE-PROTECTED?
JRST LDXQQ5
PUSH FXP,TT
LOCKI ;LOCK OUT INTS AROUND USE OF TMPC
SKIPN SGANAM
JRST FASLUH
MOVEI T,.IODMP
MOVE TT,SGADEV
SETZ D,
OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE
JRST FASLUH
MOVE T,SGANAM
MOVE TT,SGAEXT
SETZ D,
MOVE R,SGAPPN
LOOKUP TMPC,T
JRST FASLUR
SA$ MOVS T,R
SA% JUMPGE R,FASLUR
SA% HLRE T,R
MOVNS T ;T GETS LENGTH OF .SHR FILE
PUSHJ P,LDRIHS ;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!)
LDRTHS: RELEASE TMPC, ;FLUSH TEMP CHANNEL
UNLOCKI
POP FXP,TT
MOVE F,SVPRLK ;CAN NOW USE SAVED PURE SEGMENTS FROM LAST TIME
SETZM SVPRLK
MOVEM F,PRSGLK
LDXQQ5: MOVSI F,100000
IORM F,(P) ;SET FLAG SAYING WE'RE HACKING THE HISEG
MOVMS TT
PUSHJ P,LDXHHK ;SET UP XCT PAGES USING HISEG
MOVE A,V.PURE
PUSHJ P,FIXP ;LEAVES VALUE IN TT IN INDEED FIXNUM
JUMPE A,LDXXX1 ;IF FIXNUM, IT IS AN ESTIMATE OF PURE FREE STG
CAIG TT,10 ;IF 10 OR LESS, MULTIPLY BY 1024.
LSH TT,12
CAILE TT,0 ;CHECK FOR REASONABLENESS
CAILE TT,MEMORY+.RL1-ENDHI
JRST LDYERR
MOVSI D,-NFF-1
SUB TT,PFSSIZ(D) ;SUBTRACT FROM ESTIMATE THE CURRENT
AOBJN D,.-1 ; SIZES OF EXISTING PURE AREAS
MOVE D,PRSGLK
LDXQQ2: JUMPE D,LDXQQ3 ;ALSO ACCOUNT FOR ANY PURE SEGMENTS
SUBI TT,SEGSIZ ; ALREADY IN THE FREELIST
LDB D,[SEGBYT,,GCST(D)]
JRST LDXQQ2
LDXQQ3: JUMPLE TT,LDXXX1 ;JUMP IF GUESSTIMATE ALREADY SATISFIED
ADDI TT,SEGSIZ-1 ;ROUND UP TO AN INTEGRAL
ANDI TT,SEGMSK ; NUMBER OF SEGMENTS
MOVE D,HBPORG
ADDI D,SEGSIZ-1 ;ALSO ROUND UP HISEG BPORG
ANDI D,SEGMSK
MOVE R,D
ADD D,TT
SUBI D,1
TLNE D,-1
JRST FASLNX ;COMPLAIN IF NOT ENOUGH MEMORY
MOVEM D,HBPORG ;UPDATE HISEG BPORG PAST ALLOCATED SEGMENTS
AOS HBPORG
CAMG D,HBPEND
JRST LDXQQ6
MOVEM D,HBPEND ;IF NEW HISEG BPORG TOO LARGE,
SA% HRLZI D,(D)
SA% CORE D,
SA$ CORE2 D, ; MUST REQUEST MORE CORE FOR HISEG
JRST FASLNX ;COMPLAIN IF NOT ENOUGH MEMORY
LDXQQ6: LSH R,-SEGLOG ;UPDATE SEGMENT TABLES,
LSH TT,-SEGLOG ; AND ADD PURE SEGMENTS TO FREELIST
MOVE D,[$XM+PUR,,QRANDOM]
MOVE F,PRSGLK
LDXQQ8: MOVEM D,ST(R)
SETZM GCST(R)
DPB F,[SEGBYT,,GCST(R)]
MOVEI F,(R)
ADDI R,1
SOJG TT,LDXQQ8
MOVEM F,PRSGLK
JRST LDXXX1
] ;END OF IFN <PAGING-1>*HISEGMENT
IFN D10*<PAGING-1>,[
LDXQQ7:
HS% MOVMS TT
PUSHJ P,LDXHAK ;SET UP XCT HACK PAGES WITHOUT HISEG
] ;END IFN D10*<PAGING-1>
;FALLS THROUGH
;LDXXX1 LDXXX9
;FALLS IN
LDXXX1: MOVE TT,[-LLDAT+1,,1] ;INIT ATOMTABLE AOBJN INDEX
MOVEM TT,LDAAOB
MOVEI TT,LLDAT ;CREATE ATOMTABLE ARRAY
MOVSI A,400000
PUSHJ P,MKLSAR
PUSH P,A ;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION
HRRZM B,LDASAR ;SAVE ADDRESS OF SAR
PUSHJ P,LDLRSP ;LOCKI, AND SET UP ARRAY POINTERS
SETZ TT, ;ENTRY 0 IN ATOMTABLE IS FOR NIL
SETZM @LDAPTR
MOVEI TT,LDFERR ;INIT ADDRESS FOR PREMATURE EOF
MOVEM TT,LDEOFJ
SKIPE F,LDTEMP ;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER
JRST LDXXX9
JSP T,LDGTW1 ;GET FIRST WORD OF FILE
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\] ;IT BETTER BE THIS VALUE!
JSP D,LDFERR
LDXXX9: JSP T,LDGTWD ;GET VERSION OF LISP FILE WAS ASSEMBLED IN
XOR TT,LDFNM2
MOVEM TT,LDF2DP ;NON-ZERO IFF VERSIONS DIFFERENT
MOVE AR1,[000400,,LDBYTS] ;INIT RELOCATION BYTES POINTER
SETZM LDHLOC
HRRZ R,@VBPORG
HS$ 10$ MOVE TT,LDPRLS(P)
HS$ 10$ TLNE TT,100000 ;SKIP UNLESS LOADING INTO HISEG
HS$ 10$ HRRZ R,HBPORG
HRRM R,LDOFST ;INITIALIZE LOAD OFFSET
JRST LDABS0 ;R HAS ADDRESS TO LOAD NEXT WORD INTO
;LDXHHK LDXHAK LDXHK1 LDXHK2 LDXHK3 LDXHK5
SUBTTL ROUTINE TO SET UP PAGES FOR XCT HACK (NON-PAGING, FIXED NUMBER OF SLOTS)
IFE PAGING,[
;;; TT HAS NUMBER OF WORDS (1K BLOCKS IF <8) DESIRED.
LDXHHK: HRROS (P) ;THIS ENTRY USES THE HISEG
LDXHAK: SKIPE LDXSIZ ;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY
POPJ P, ;IF NOT, JUST EXIT
JUMPLE TT,LDXERR
CAIG TT,10 ;IF 10 OR LESS, MULTIPLY BY 1024.
LSH TT,12
ADDI TT,PAGSIZ-1 ;ROUND UP TO A WHOLE NUMBER OF PAGES
ANDI TT,PAGMSK
TLNE TT,-1
JRST LDXERR
PUSH FXP,TT
MOVE D,(FXP) ;GET ESTIMATED NUMBER OF LINKS
MOVEM D,LDXSIZ ;SAVE AS SIZE OF XCT AREA
MOVEM D,LDXSM1 ;ALSO NEED THAT VALUE MINUS 1
SOS LDXSM1
MOVE TT,@VBPORG ;CREATE TWO AREAS IN BPS THAT BIG:
HRRZ T,TT ; THE FIRST FOR THE XCTS TO POINT TO,
ADD TT,D ; THE SECOND TO RESTORE THE FIRST FROM
HRL T,TT
MOVE R,(P)
TLNE R,1
HRL T,HBPORG
MOVEM T,LDXBLT ;SAVE BLT POINTER FOR RESTORING
TLNN R,1 ;USING HISEG, DON'T TAKE SECOND AREA FROM LOSEG
ADD TT,D ;ADD IN FOR SECOND AREA
JSP T,FXCONS ;NEW VALUE FOR BPORG
PUSH P,A
TLNN R,1
LSH D,1
MOVE TT,D
PUSHJ P,LGTSPC ;NOW TRY TO GET REQUIRED CORE
JUMPE TT,FASLNX
MOVE R,-1(P)
TLNN R,1
JRST LDXHK3
MOVE D,(FXP) ;GOBBLE SECOND AREA OUT OF HISEG
ADD D,HBPORG
TLNN D,-1
JRST LDXHK2
LDXHK1: SETZM LDXSIZ ;HAVEN'T REALLY WON AFTER ALL
JRST FASLNX
LDXHK2: MOVEM D,HBPORG
SUBI D,1
CAMG D,HBPEND ;MAY NEED TO EXTEND HISEG
JRST LDXHK3
MOVEM D,HBPEND
SA% HRLZI D,(D)
SA% CORE D,
SA$ CORE2 D,
JRST LDXHK1
LDXHK3: POP P,VBPORG ;GIVE BPORG NEW VALUE
MOVE T,LDXBLT ;ZERO OUT BOTH AREAS
MOVE TT,@VBPORG
HRL T,T
SETZM (T)
ADDI T,1
BLT T,-1(TT)
TLNN R,1
JRST LDXHK5
MOVS T,LDXBLT ;WHEN USING HISEG, NEED AN EXTRA
MOVE TT,HBPORG ; BLT TO ZERO OUT SECOND AREA
BLT T,-1(TT)
LDXHK5: HRRZ T,LDXBLT ;SET UP LDXDIF WITH THE DIFFERENCE
HLRZ TT,LDXBLT ; BETWEEN THE ORIGINS OF AREA 1 AND
SUB T,TT .SEE LDPRC6
HRRM T,LDXDIF ; AREA 2 TO MAKE INSTALLING ENTRIES EASIER
POPI FXP,1
JRST TRUE
] ;END IFE PAGING
;LDXHAK LDXFLC LDXIRL LDREL LDABS LDABS1 LDABS0 LDBIN LDBIN1 LDBIN2 LDTTBL
SUBTTL PAGING, VARIABLE NUMBER OF XCT PAGES, DYNAMICALLY ALLOCATED
IFN PAGING,[
LDXHAK: PUSH FXP,AR1 ;AR1 MUST BE PRESERVED, AT ALL COSTS!
LOCKI ;INTERRUPTS MUST BE OFF OVER CALL TO GRBSEG
PUSHJ P,GRBSEG ;GET ONE SEGMENT OF TYPE RANDOM
JRST LDXIRL ;RELEASE INTERRUPTS AND GIVE NON-SKIP RETURN
UNLOCKI
PUSHJ P,GRBPSG ;GET ONE PURE SEGMENT INTO AC T
POP FXP,AR1
LSH T,SEGLOG ;MAKE PURE SEGMENT INTO ADDRESS
HRRZM T,LDXPSP(TT) ;REMEMBER PURE SEGMENT ADDRESS
HRLI T,(T) ;BUILD A BLT POINTER TO ZERO PURE PAGE
HRRZI D,SEGSIZ-1(T) ;LAST LOC TO ZERO
SETZM (T) ;ZERO FIRST LOC
ADDI T,1
BLT T,(D) ;AND ALL THE REST
HRLZI T,LDXOFS(TT) ;BUILD BLT POINTER TO CLEAR NEW IMPURE SEG
HRRI T,LDXOFS+1(TT)
SETZM LDXOFS(TT)
BLT T,SEGSIZ-1(TT) ;CLEAR THE WHOLE SEGMENT
MOVNI T,LDHSH1+1 ;NUMBER OF ENTRIES IN TABLE
IMULI T,LDX%FU ;MAKE INTO NEGATIVE PERCENTAGE
PUSH FXP,TT
IDIVI T,100.
POP FXP,TT
MOVEM T,LDXLPC ;AND THE COUNT
MOVE T,LDXLPL ;REMEMBER LOC OF LAST PAGE USED
MOVEM TT,LDXLPL ;SAVE THIS PAGE LOCATION
JUMPE T,LDXFLC ;STORE IN POINTER LOC IF NO PREVIOUS SEGMENTS
HRLM TT,(T) ;LINK INTO LIST
AOS (P)
POPJ P,
LDXFLC: MOVEM TT,LDXPNT
AOS (P)
POPJ P,
LDXIRL: UNLOCKI
POP FXP,AR1
POPJ P,
] ;END IFN PAGING
SUBTTL MAIN FASLOAD LOOP
;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;; AR1 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
;;; F AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY
LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD]
LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD]
LDABS1: AOBJN R,LDBIN ;JUMP IF ROOM LEFT OF WHAT WE GRABBED
LDABS0:
10$ MOVE TT,LDPRLS(P) ;FOR D10, MUST PASS LDPRLS IN TT TO LDGTSP
PUSHJ P,LDGTSP
PUSHJ P,LDRSPT
LDBIN: SKIPE INTFLG ;[LOAD BINARY WORD (OR SOME OTHER MESS)]
PUSHJ P,LDTRYI ;GIVE A POOR INTERRUPT A CHANCE IN LIFE
TLNN AR1,770000
JRST LDBIN2 ;OUT OF RELOCATION BYTES - MUST GET MORE
LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE
ILDB T,AR1 ;GET CORRESPONDING RELOCATION BYTE
JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO
LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES
MOVEM TT,LDBYTS
SOJA AR1,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD
LDTTBL: LDABS ; 0 ABSOLUTE
LDREL ; 1 RELOCATABLE
LDSPC ; 2 SPECIAL
LDPRC ; 3 PURIFIABLE CALL
LDQAT ; 4 QUOTED ATOM
LDQLS ; 5 QUOTED LIST
LDGLB ; 6 GLOBALSYM PATCH
LDGET ; 7 GET DDT SYMBOL PATCH
LDAREF ; 10 ARRAY REFERENCE
LDFERR ; 11 UNUSED
LDATM ; 12 ATOMTABLE ENTRY
LDENT ; 13 ENTRY POINT INFO
LDLOC ; 14 LOC TO ANOTHER PLACE
LDPUT ; 15 PUT DDT SYMBOL
LDEVAL ; 16 EVALUATE MUNGEABLE
LDBEND ; 17 END OF BINARY
;LDGTSP LDGS0A LDGS0H LDGSP1 LDGSP3 LDGSP5 LDGSP4 LDGSP6
;;; LOADER GET SPACE ROUTINE. PUTS SOME DISTANCE BETWEEN BPORG AND BPEND.
;;; R MUST BE SET UP ALREADY. FOR D10, TT MUST HAVE LDPRLS.
;;; THE LEFT HALF OF R IS ADJECTED TO REFLECT THE SPACE OBTAINED.
LDGTSP:
HS$ 10$ TLNE TT,100000 ;CHECK IF LOADING INTO HISEG
HS$ 10$ JRST LDGSP3 ;IF SO, EXPAND THAT
MOVE TT,@VBPEND ;SEE IF ENOUGH ROOM LEFT TO GRAB MORE
SUB TT,@VBPORG
SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY
JUMPGE TT,LDGSP1 ;YES - GO GRAB IT
SAVEFX AR1 D R F
MOVEI TT,4*PAGSIZ ;GET MANY BLOCKS OF BPS
LDGS0A: MOVEM TT,GAMNT
PUSHJ P,GTSPC1
JUMPN TT,LDGS0H
MOVE TT,GAMNT
CAIG TT,100
JRST FASLNC
MOVEI TT,100
JRST LDGS0A
LDGS0H: RSTRFX F R D AR1
LDGSP1: MOVEI TT,(R)
ADDI TT,PAGSIZ ;TRY TO GOBBLE <PAGSIZ>
CAMLE TT,@VBPEND ; WORDS, BUT IN ANY CASE
MOVE TT,@VBPEND ; NO MORE THAN BEYOND BPEND
JSP T,FIX1A
MOVEM A,VBPORG
MOVEI TT,(R)
SUB TT,@VBPORG
HRLI R,(TT) ;INIT AOBJN POINTER IN R
POPJ P,
IFE PAGING+<1-D10>,[
LDGSP3: MOVE TT,HBPEND
SUBI TT,(R) ;DO NOT MERGE THIS WITH FOLLOWING SUBI! MAYBE R>777700
SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY
JUMPGE TT,LDGSP6
MOVE TT,HBPEND
ADDI TT,4*PAGSIZ
TLNE TT,-1
MOVSI TT,(MEMORY)
ADDI TT,PAGSIZ-1
ANDCMI TT,#PAGMSK ;*NOT* SAME AS ANDI TT,PAGMSK !!!
MOVE T,TT
SUBI T,1
CAMG T,HBPEND
JRST LDGSP4
SA% HRLZI T,(T)
SA% CORE T,
SA$ CORE2 T,
JRST FASLNC
MOVE AR2A,[$XM+PUR,,QRANDOM]
AOS B,HBPEND
MOVEI C,(B)
SUBI C,(TT)
LSHC B,-SEGLOG
HRLI B,(C)
LDGSP5: MOVEM AR2A,ST(B)
SETZM GCST(B)
AOBJN B,LDGSP5
LDGSP4: MOVEM TT,HBPEND
SOS HBPEND
LDGSP6: MOVE TT,HBPEND
MOVEM TT,HBPORG
SUBM R,TT
HRLI R,(TT)
POPJ P,
] ;END OF IFE IFE PAGING+<1-D10>
;LDSPC LDSPC1 LDQAT
SUBTTL SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES
LDSPC: MOVE T,TT ;[SPECIAL]
HLR TT,@LDAPTR ;GET ADDRESS OF SPECIAL CELL
TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE?
JRST LDABS ;YES, WIN
TRNE TT,6 ;NO, IS THIS ATOM A NUMBER
JSP D,LDFERR ;YES - LOSE!!!
HRRZ TT,T ;IS THERE AN ATOM THERE AT ALL
HRRZ A,@LDAPTR
SKIPN D,A
JSP D,LDFERR ;NO, LOSE
HLRZ B,(A)
HRRZ A,(B)
CAIE A,SUNBOUND
JRST LDSPC1
PUSH P,D ;NONE THERE - MUST MAKE ONE
MOVEI B,QUNBOUND
JSP TT,MAKVC ;RETURN SY2 POINTER IN B
LDSPC1: HLRZ TT,(B) ;GET SYMBOL FLAG BITS
TRO TT,SY.CCN\SY.OTC ;NEEDED-BY-COMPILED-CODE, OTHER THAN CALL
TRNN TT,SY.PUR ;WAS VALUE CELL PURE?
HRLM TT,(B) ;NO, THEN MUST PROTECT VALUE CELL
MOVE TT,T ;SAVE ADDRESS OF VALUE CELL
HRLM A,@LDAPTR ; IN ATOMTABLE
HRR TT,A ;AT LAST WE WIN
JRST LDABS
LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM]
TLNN D,777001 ;SKIP IF SPECIAL OR ALREADY USED
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
HRRI TT,(D)
TRNN D,-1
JRST LDABS ;DON'T HACK ANYTHING FOR NIL
TLNE D,777006 ;IF NUMBER OR ALREADY HACKED SYM BLK, SKIP IT
JRST LDABS
HLRZ T,(D)
HLL T,(T) ;FETCH SYMBOL BITS
TLO T,SY.CCN\SY.OTC ;FLAG SYMBOL AS NEEDED FOR OTHER THAN CALL
TLNN T,SY.PUR ;DON'T TRY TO WRITE IF PURE
HLLM T,(T)
JRST LDABS
;LDQLS LDQLS3 LDQLS1 LDQLS2 LDQLS5 LDQLS4 LDQLPRO LDGPRO
SUBTTL QUOTED LIST REFERENCES
LDQLS: MOVSI D,11 ;[QUOTED LIST]
SKIPL LDPRLS(P) ;CAN'T COUNT ON ANYTHING IN PURE
MOVSI D,1 ; FREE STORAGE PROTECTING ANYTHING
PUSHJ P,LDLIST ;GOBBLE UP A LIST
MOVEM TT,(R) ;PUT WORD IN BPS
JSP T,LDGTWD ;GET HASH KEY FOR LIST
TLZ A,-1
SKIPE VGCPRO
JRST LDQLS4
PUSH FXP,D
PUSH FXP,AR1
TLZ A,-1
SKIPE D,TT
JRST LDQLS3
PUSH P,A
PUSHJ P,SXHSH0
POP P,A
LDQLS3: SKIPN V.PURE ;SKIP FOR PURE HACKERY
JRST LDQLS1
PUSH FXP,D ;SAVE HASH KEY
PUSH P,A ;SAVE LIST
MOVNI T,1 ;THIS MEANS JUST LOOKUP
PUSHJ P,LDGPRO
POP P,B
POP FXP,D
JUMPN A,LDQLS2 ;ON GCPRO LIST, SO USE IT
MOVE A,B
PUSHJ P,PURCOPY ;NOT ON GCPRO LIST, SO PURCOPY IT
LDQLS1: MOVEI T,1 ;THIS MEANS PROTECT OR HAND BACK COPY
PUSHJ P,LDGPRO ;PROTECT LIST FROM FEROCIOUS GC!
LDQLS2: POP FXP,AR1
POP FXP,D
LDQLS5: JUMPE D,LDEVL7 ;MAYBE THIS LIST GOES INTO ATOMTABLE
HRRM A,(R) ;SAVE ADDRESS OF LIST (WHICH MAY
JRST LDABS1 ; BE DIFFERENT NOW) BACK INTO WORD
LDQLS4: JSP T,LDQLPRO
JRST LDQLS5
LDQLPRO:
HRRZ B,LDEVPRO ;GC-PROTECT HAPPENS BY PUSHING ONTO A LIST
PUSHJ P,CONS
MOVEM A,LDEVPRO
JRST %CAR
LDGPRO: SKIPE GCPSAR ;PROTECT SOMETHING ON THE GCPSAR
JRST .GCPRO
PUSHJ P,.GCPRO ;THE LOOKUP CAUSES THE CREATION OF A NEW ARRAY
JRST LDRSPT ;SO WE HAVE TO RESTORE PTRS AFTERWARDS
;LDPRC LDPRC1 PRCHAK LDPRC2 LDPRC3 LDPRC4 LDPRC5 LDPRC6 LDPRC7
SUBTTL PURIFIABLE CALL
LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL]
TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL
JSP D,LDFERR
TLNE D,777000
JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL
TLNE D,6
JSP D,LDFERR ;LOSE IF NUMBER
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
HLRZ T,(D) ;FETCH SY2 DATA
HLL T,(T)
TLO T,SY.CCN ;ONLY CCN, NOT OTC!!
TLNN T,SY.PUR ;ONLY IF IMPURE
HLLM T,(T)
LDPRC1: HRR TT,D ;PUT ADDRESS OF ATOM IN CALL
SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY
JRST LDABS ;OTHERWISE WE'RE DONE
TLNN T,200000 ;SKIP FOR XCT STUFF
SETZ T, ;ELSE DO ORDINARY SMASH
PUSHJ P,PRCHAK ;*** SMASH! ***
JRST LDABS1
MOVEI A,(R) ;NOT SMASHED - CONS ONTO PURE LIST
MOVE B,LDPRLS(P)
PUSHJ P,CONS
MOVEM A,LDPRLS(P)
JRST LDABS1
;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK.
;;; SKIPS ON *** FAILURE *** TO CLOBBER.
;;; T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH.
;;; TT HAS UUO INSTRUCTION TO HACK.
;;; R HAS ADDRESS TO PUT UUO INTO.
;;; MUST PRESERVE AR1, R, F.
IFE PAGING,[
;VERSION FOR NON-PAGING ONLY, NEWER VERSION SUPPORTS EXTENDABLE NUMBER OF SEGMENTS
PRCHAK: JUMPE T,LDPRC5 ;T ZERO => ORDINARY SMASH
MOVE T,TT ;SAVE CALL IN T
IDIV TT,LDXSM1 ;COMPUTE HASH CODE FOR CALL
MOVNM D,LDTEMP ;SAVE NEGATIVE THEREOF
HLRZ TT,LDXBLT
ADD D,TT ;ADDRESS TO BEGIN SEARCH
CAMN T,(D) ;WE MAY WIN IMMEDIATELY
JRST LDPRC7
SKIPN (D)
JRST LDPRC6
ADD TT,LDXSM1 ;ELSE MAKE UP AN AOBJN POINTER
SUBI TT,-1(D) ; AND SEARCH FOR MATCHING CALL
MOVNI TT,(TT)
HRL D,TT
LDPRC2: CAMN T,(D)
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC2
HRLZ D,LDTEMP ;WRAPPED OFF THE END OF THE XCT AREA
HLR D,LDXBLT ; - MAKE UP NEW AOBJN POINTER
LDPRC3: CAMN T,(D) ;SECOND COPY OF THE LOOP
JRST LDPRC7 ;FOUND MATCHING CALL
SKIPN (D)
JRST LDPRC6 ;FOUND EMPTY SLOT
AOBJN D,LDPRC3
LDPRC4: MOVE TT,T ;TOTAL LOSS - MUST DO SMASH
LDPRC5: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A
MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE
JRST LDSMSH ;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
LDPRC6: SKIPG LDXSIZ ;FOUND EMPTY SLOT
JRST LDPRC4 ;CAN'T USE IT IF PAGES PURIFIED
MOVEM T,(D) ;SAVE CALL INTO XCT AREA 2
MOVEM T,@LDXDIF ;ALSO SAVE INTO AREA 1
LDPRC7: ADD D,LDXDIF ;MAKE UP AN XCT TO POINT TO
HRLI D,(XCT) ; CALL IN AREA 1
MOVEM D,(R)
POPJ P,
] ;END IFE PAGING
;PRCHAK PRCSMS PRCHA1 PRCH1A PRCH1B PRCHA4 PRCHA3 PRCHA2 PRCH2A PRTRTS
IFN PAGING,[
;NEW STYLE SEARCH FOR PROPER LINK LOCATION; ADDS A NEW UUOLINKS SEGMENT IF
; OUT OF SPACE OR IF PARTIALLY EMPTY UUOLINK SEGMENT HAS BEEN PURIFIED
PRCHAK: JUMPN T,PRCHA1 ;DON'T SMASH IMMEDIATLY IF T NON-ZERO
PRCSMS: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A
MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE
JRST LDSMSH ;TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
PRCHA1: PUSH FXP,R ;NEED D/R PAIR OF ACS
MOVE D,TT ;GET COPY OF THE CALL
IDIVI D,LDHSH1 ;COMPUTE FIRST HASH VALUE
MOVEM R,LDXHS1
MOVE D,TT ;THEN THE SECOND HASH VALUE
IDIVI D,LDHSH2
AOS R ;IT BEING ZERO COULD BE A DISASTER
MOVEM R,LDXHS2
SKIPN T,LDXPNT ;GET POINTER
JRST PRCH2A ;FIRST TIME THROUGH ALWAYS ADD NEW SEGMENT
PRCH1A: HRRZ D,LDXPSP(T) ;GET POINTER TO PURE PAGE
MOVEI R,LDXOFS(D) ;POINTER TO FIRST WORD OF DATA
ADDI D,SEGSIZ-1 ;THIS IS THE LAST WORD IN THE SEGMENT
ADD R,LDXHS1 ;START FROM THE FIRST HASH VALUE
PRCH1B: CAMN TT,(R) ;MATCH?
JRST PRCHA3 ;YUP, SO USE THIS SLOT
SKIPN (R) ;END OF CHAIN?
JRST PRCHA4 ;YES, ON TO NEXT SEGMENT
ADD R,LDXHS2 ;STEP BY HASH VALUE
CAILE R,(D) ;MUST NOT RUN OFF END OF SEGMENT
SUBI R,LDHSH1 ;SO TAKE IT MOD LDHSH1
JRST PRCH1B ;AND TRY THIS SLOT
PRCHA4: HLRZ D,LDXPSP(T) ;GET POINTER TO NEXT SEGMENT
JUMPE D,PRCHA2
MOVEI T,(D)
JRST PRCH1A
PRCHA3: HRRZ D,LDXPSP(T) ;SUBTRACTING THIS WILL GIVE ABSOLUTE SEG OFFSET
SUBM R,D
ADDI D,(T) ;THEN PRODUCE POINTER TO FROB TO XCT
POP FXP,R ;RESTORE POINTER TO CODE
HRLI D,(XCT)
MOVEM D,(R) ;THEN STORE THE NEW INSTRUCTION
POPJ P,
;GET HERE WITH C(R) POINTING TO SLOT TO ADD NEW ENTRY TO IN PURE TABLE, DUE TO
; THE DESIGN OF THE MECHANISM, IN THE CASES THAT R IS INVALID, A NEW UUO PAGE
; WILL HAVE TO BE ADDED AND R WILL NOT BE USED. IF THAT IS CHANGED, THIS
; ROUTINE MUST BE FIXED
PRCHA2: AOSLE LDXLPC ;IF THIS SEGMENT IS FULL
JRST PRCH2A ; ADD A NEW ONE
MOVEM TT,(R) ;STORE THE CALL IN THE POTENTIALLY PURE SEGMENT
HRRZ D,LDXPSP(T) ;THEN BUILD POINTER TO IMPURE SEGMENT
SUBM R,D
ADDI D,(T) ;D CONTAINS ADR IN IMPURE SEGMENT
MOVEM TT,(D) ;STORE THE CALL INSTRUCTION THERE
POP FXP,R ;GET ADR OF ACTUAL CODE
HRLI D,(XCT) ;THEN INSTRUCTION TO PLANT THERE
MOVEM D,(R)
POPJ P,
PRCH2A: PUSH FXP,TT ;SAVE TT OVER SEGMENT GRAB
PUSHJ P,LDXHAK ;ADD A NEW SEGMENT
LERR [SIXBIT \CANNOT ADD NEW UUOLINKS SEGMENT - FASLOAD!\]
POP FXP,TT
MOVE T,LDXLPL ;GET POINTER TO THE PAGE JUST ADDED
MOVEI D,LDXOFS(T) ;FIRST DATA ADR
ADD D,LDXHS1 ;ADR TO INSTALL CALL INTO
MOVEM TT,(D) ;STORE THE CALL TO BE POTENTIALLY SMASHED
HRLI D,(XCT) ;THE XCT INSTRUCTION
POP FXP,R
MOVEM D,(R) ;PLANT IN CODE
HRRZ D,LDXPSP(T) ;PURE SEGMENT POINTER
ADD D,LDXHS1
ADDI D,LDXOFS
MOVEM TT,(D) ;PLANT CALL IN POTENTIALLY PURE SEGMENT
POPJ P,
;HERE TO TRY TO SMASH CALL IN IMPURE SEGMENT. CALLED ONLY IF FLAG IS SET.
; POINTER TO WORD IN THE SEGMENT IS IN D. DESTROYS A, B, C, T
PRTRTS: HRRZ AR2A,D ;PUT ADDRESS OF CALL IN AR2A
PUSH FXP,D ;SAVE VALUABLE AC'S
PUSH FXP,TT
PUSH FXP,T
PUSHJ P,LDSMSH ;TRY TO SMASH THE CALL
JFCL ;WE DON'T REALLY CARE IF IT WINS OR NOT
POP FXP,T
POP FXP,TT
POP FXP,D
POPJ P,
] ;END IFN PAGING
;LDSMSH LDZA2 LDZAOK LDZA1 LDSMNS
;;; SMASH A CALL-TYPE UUO IN MEMORY TO BE A PUSHJ OR JRST OR WHATEVER.
;;; AR2A HAS THE LOCATION OF THE CALL.
;;; RETURN SKIPS IF IT CAN'T BE SMASHED.
;;; DESTROYS A, B, C, T, TT, D; SAVES AR1, AR2A, R, F.
;;; MUST NOT USER ANY PDL EXCEPT THE REGPDL (P).
.SEE PURIFY
LDSMSH: MOVE T,(AR2A)
LSH T,-33 ;T GETS THE CALL UUO OPCODE
CAIL T,CALL←-33
CAILE T,CALL←-33+NUUOCLS
POPJ P, ;RETURN IF NOT REALLY A CALL
HRRZ A,(AR2A)
MOVEI B,SBRL
PUSHJ P,GETLA ;TRY TO GET SUBR, FSUBR, OR LSUBR PROP
LDB D,[270400,,(AR2A)]
JUMPE A,LDSMNS ;JUMP IF NOT ANY OF THOSE
HLRZ B,(A)
HRRZ T,(AR2A)
HLRZ T,(T)
HLRZ T,1(T) ;GET ARGS PROPERTY FOR FUNCTION NAME
SOJL T,LDZA2 ;JUMP IF THERE ISN'T ANY
CAIG T,NACS ;ARGS PROPERTY IS SCREWY IF THIS SKIPS!
TLOA T,(CAIE D,) ;IF ARGS PROP OK, TEST FOR THAT EXACT NUMBER OF ARGS IN UUO
LDZA2: MOVE T,[CAILE D,NACS] ;IF NO OR BAD ARGS PROP, JUST CHECK FOR RANGE
CAIN B,QFSUBR
MOVE T,[CAIE D,17]
CAIN B,QLSUBR
MOVE T,[CAIE D,16]
XCT T ;AC FIELD OF CALL IS 0-5 FOR SUBRS, 16 LSUBR, 17 FSUBR
JRST POPJ1 ;SKIP RETURN IF CALL DOESN'T MATCH FUNCTION TYPE OR # ARGS
HRRZ A,(A) ;ELSE WIN - SMASH THE CALL
HLRZ A,(A) ;SUBR ADDRESS NOW IN A
SKIPA TT,(AR2A)
LDZAOK: HRLI A,(@) .SEE ASAR
MOVSI T,(PUSHJ P,) ;CALL BECOMES PUSHJ
TLNE TT,20000
ADDI A,1 ;HACK NCALLS CORRECTLY - ENTER AT ROUTINE+1
TLNE TT,1000
MOVSI T,(JRST) ;JCALL BECOMES JRST
LDZA1: IOR T,A
MOVEM T,(AR2A) ;***SMASH!***
POPJ P,
LDSMNS: HRRZ A,(AR2A) ;TRY TO GET ARRAY PROPERTY
MOVEI B,QARRAY
PUSHJ P,GET
MOVEI T,(A)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,SA
JRST POPJ1 ;LOSE IF NOT SAR
LDB T,[TTSDIM,,TTSAR(A)]
CAIE T,(D) ;MUST HAVE CORRECT NUMBER OF ARGS
JRST POP1J
MOVSI T,TTS<CN>
IORM T,TTSAR(A) ;SET "COMPILED-CODE-NEEDS-ME" BIT IN SAR
MOVE TT,(AR2A)
TLNN TT,20000
JRST LDZAOK
MOVSI T,(ACALL) ;FOR AN NCALL-TYPE UUO, SMASH IT TO
TLNE TT,1000 ; BE A CROCKISH ACALL OR AJCALL
MOVSI T,(AJCALL)
JRST LDZA1
;LDGET LDGET1 LDGET2 LDGT5A LDGET4 LDGT5B
SUBTTL GETDDTSYM HACKERY
LDGET: CAMN TT,XC-1
JRST LDLHRL
MOVE D,TT ;[GET DDT SYMBOL PATCH]
TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE?
JRST LDGET2
JSP T,LDGTWD ;FETCH IT THEN
SKIPE LDF2DP
JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER
LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL?
MOVNS TT
LDB D,[400200,,D] ;GET FIELD NUMBER
XCT LDXCT(D) ;HASH UP VALUE FOR FIELD
MOVE T,LDMASK(D) ;ADD INTO FIELD
ADD TT,-1(R) ; MASKED APPROPRIATELY
AND TT,T
ANDCAM T,-1(R)
IORM TT,-1(R)
JRST LDBIN
LDGET2: UNLOCKI ;UNLOCK INTERRUPTS
PUSH FXP,. ;RANDOM FXP SLOT
PUSH FXP,AR1 ;SAVE UP ACS
PUSH FXP,D
PUSH FXP,R
PUSH FXP,F
MOVEI R,0
TLZ D,740000
REPEAT LOG2LL5,[
CAML D,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
ADDI R,1←<LOG2LL5-.RPCNT-1>
] ;END OF REPEAT LOG2LL5
CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F)
MOVE TT,LSYMS(TT)
JRST LDGT5B
LDGT5A: MOVEI TT,R70
CAMN D,[SQUOZE 0,R70]
JRST LDGT5B
PUSHJ P,UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL
MOVEI C,(A)
MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY
PUSHJ P,GET
JUMPN A,LDGETJ ;WIN
IFN ITS,[
JSP T,SIDDTP ;MAYBE WE CAN GET VALUE FROM DDT?
JRST LDGETX
LDB T,[004000,,-2(FXP)]
.BREAK 12,[..RSYM,,T]
JUMPE T,LDGETX ;LOSE, LOSE, LOSE
] ;END OF IFN ITS
IFN D10,[
SKIPN .JBSYM"
JRST LDGETX
LDB D,[004000,,-2(FXP)]
LDGET4: MOVE TT,D
IDIVI D,50
JUMPE R,LDGET4
PUSHJ P,GETDD0
JRST LDGETX
] ;END OF IFN D10
LDGT5B: MOVEM TT,-4(FXP) ;WIN, WIN - USE RANDOM FXP SLOT
MOVEI A,-4(FXP) ; TO FAKE UP A FIXNUM
JRST LDGETJ
;LDGETX LDGETJ LDGETV LDGETW LDGET6 LDGDDT LDGDDT LDGDDT LDXCT LDMASK LDLHRL
LDGETX: MOVEI A,(C)
PUSHJ P,NCONS
MOVEI B,QGETDDTSYM ;DO A FAIL-ACT
PUSHJ P,XCONS
PUSHJ P,LDGETQ
LDGETJ: POP FXP,F ;RESTORE ACS
POP FXP,R
POP FXP,D
POP FXP,AR1
PUSHJ P,LDLRSP ;LOCKI AND RESTORE ARRAY POINTERS
MOVE TT,(A)
PUSHJ P,TYPEP ;FIGURE OUT WHAT WE GOT BACK
POP FXP,-1(FXP) ;POP RANDOM SLOT (REMEMBER THE LOCKI!)
CAIN A,QFIXNUM
JRST LDGET1
LDGETV: CAIN A,QFLONUM ;USE A FLONUM IF WE GET ONE
JRST LDGET1
LDGETW: PUSHJ P,LDGDDT ;FOR ANYTHING ELSE TRY DDT AGAIN
MOVEM TT,LDDDTP(P)
JRST LDGET2
LDGET6: REPEAT 4,[<11←24.>+<<<3-.RPCNT>*11>←30.> LAP5P(R)
]
IFN ITS,[
LDGDDT: JSP T,SIDDTP
JRST ZPOPJ ;0 => TOP LEVEL, OR NOT INFERIOR TO DDT
.BREAK 12,[..RSTP,,TT] ;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE
SKIPN TT ;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE
TLOA TT,-1
MOVSI TT,1
POPJ P,
] ;END OF IFN ITS
IFN D20,[
LDGDDT==:ZPOPJ ;FOR NOW, NEVER A DDT
] ;END IFN D20
IFN D10,[
LDGDDT: SKIPE TT,.JBSYM"
MOVSI TT,1
POPJ P,
] ;END OF IFN D10
LDXCT: MOVSS TT ;INDEX FIELD
HRRZS TT ;ADDRESS FIELD
LSH TT,23. ;AC FIELD
JFCL ;OPCODE FIELD
LDMASK: -1 ;INDEX FIELD
0,,-1 ;ADDRESS FIELD
0 17, ;AC FIELD
-1 ;OPCODE FIELD
LDLHRL: HRLZ TT,LDOFST
ADDM TT,-1(R)
JRST LDBIN
;LDAREF LDARE1 LDGLB LDATM LDATBL LDATPN LDATP1 LDATP2 LDATP3 LDATP4 LDATP8
SUBTTL ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF
LDAREF: PUSH FXP,TT ;[ARRAY REFERENCE]
MOVE D,@LDAPTR
TLNN D,777001
TLO D,11
MOVEM D,@LDAPTR
TRNN D,-1
JRST LDARE1 ;SKIP IF HACKING 'NIL'
TLNE D,777000 ;IF NO VC THEN MUST HACK SYMBOL
JRST LDARE1
HLRZ T,(D)
HLL T,(T)
TLO T,SY.CCN\SY.OTC ;COMPILED CODE NEEDS, OTHER THAN CALL REF
TLNN T,SY.PUR ;CAN'T WRITE IF PURE
HLLM T,(T)
LDARE1: MOVEI A,(D)
PUSHJ P,TTSR+1 ;NCALL TO TTSR
HLL TT,(FXP)
SUB FXP,R70+1
JRST LDABS
LDGLB: SKIPL TT ;[GLOBALSYM PATCH]
SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL
MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF
ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF
HRRM TT,-1(R) ; LAST WORD LOADED
JRST LDBIN
LDATM: LDB T,[410300,,TT] ;[ATOMTABLE ENTRY]
JRST LDATBL(T)
LDATBL: JRST LDATPN ;PNAME
JRST LDATFX ;FIXNUM
JRST LDATFL ;FLONUM
BG$ JRST LDATBN ;BIGNUM
BG% JRST LDATER
DB$ JRST LDATDB ;DOUBLE
DB% JRST LDATER
CX$ JRST LDATCX ;COMPLEX
CX% JRST LDATER
DX$ JRST LDATDX ;DUPLEX
DX% JRST LDATER
.VALUE ;UNDEFINED
LDATPN: MOVEI D,(TT) ;[ATOMTABLE PNAME ENTRY]
PUSH FXP,R
CAILE D,LPNBUF
JRST LDATP2
MOVEI C,PNBUF-1
LDATP1: JSP T,LDGTWD
ADDI C,1
MOVEM TT,(C)
SOJG D,LDATP1
SETOM LPNF
JRST LDATP4
LDATP2: PUSH FXP,D
LDATP3: JSP T,LDGTWD
JSP T,FWCONS
PUSH P,A
SOJG D,LDATP3
POP FXP,T
MOVNS T
PUSHJ FXP,LISTX
SETZM LPNF
LDATP4: PUSH FXP,AR1
PUSHJ P,RINTERN
POP FXP,AR1
POP FXP,R
LDATP8: MOVE TT,LDAAOB
MOVEM A,@LDAPTR
AOBJP TT,LDAEXT
MOVEM TT,LDAAOB
JRST LDBIN
;LDATFX LDATX0 LDATX1 LDATX2 LDATX3 LDATFL LDATL0 LDATL1 LDATL2 LDATL3
LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FXP,TT
SKIPE A
LDATX0: TLOA A,10
JRST LDATX2
LDATX1: TLO A,2
JRST LDATP8
LDATX2: SKIPE V.PURE
JRST LDATX3
JSP T,FXCONS
JRST LDATX1
LDATX3: PUSHJ P,PFXCONS
JRST LDATX0
LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY]
PUSH FLP,TT
MOVEI A,(FLP)
PUSH P,AR1
PUSHJ P,GCLOOK
POP P,AR1
POP FLP,TT
SKIPE A
LDATL0: TLOA A,10
JRST LDATL2
LDATL1: TLO A,4
JRST LDATP8
LDATL2: SKIPE V.PURE
JRST LDATL3
JSP T,FLCONS
JRST LDATL1
LDATL3: PUSHJ P,PFLCONS
JRST LDATL0
;LDATBN LDATB1 LDATB2 LDATB3 LDATB6 LDATB7 LDAEXT LDRFRF
IFN BIGNUM,[
LDATBN: PUSH FXP,TT ;[ATOMTABLE BIGNUM ENTRY]
MOVEI D,(TT)
MOVEI B,NIL
LDATB1: JSP T,LDGTWD
SKIPE V.PURE
JRST LDATB2
JSP T,FWCONS
PUSHJ P,CONS
JRST LDATB3
LDATB2: PUSHJ P,PFXCONS
PUSHJ P,PCONS
LDATB3: MOVE B,A
SOJG D,LDATB1
POP FXP,TT
TLNE TT,1
TLO A,-1
SKIPE V.PURE
JRST LDATB6
PUSHJ P,BNCONS
JRST LDATB7
LDATB6: PUSHJ P,PBNCONS
TLO A,10
LDATB7: TLO A,6
JRST LDATP8
] ;END OF IFN BIGNUM
LDAEXT: MOVE T,TT ;[ATOMTABLE EXTEND]
HRLI T,-ILDAT
MOVEM T,LDAAOB
ADDI TT,ILDAT
ASH TT,1
UNLOCKI .SEE ERROR5 ;.REARRAY MAY PULL AN ERINT
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
PUSH P,[LDRFRF]
PUSH P,LDASAR
PUSH P,[TRUTH]
PUSH FXP,TT
MOVEI A,(FXP)
PUSH P,A
MOVNI T,3
JRST .REARRAY
LDRFRF: SUB FXP,R70+1 ;[RETURN FROM .REARRAY FUNCTION]
POP FXP,F
POP FXP,R
POP FXP,AR1
PUSHJ P,LDLRSP
JRST LDBIN
;LDENT LDENT4 LDNRDF LDPARG LDPRG3
SUBTTL ENTRY POINT
LDENT: HRRZ C,@LDAPTR ;[ENTRY POINT INFO]
MOVSS TT
HRRZ A,@LDAPTR
PUSH P,A
PUSH P,C
SKIPN B,VFASLOAD
JRST LDNRDF
CAIN B,TRUTH ;IF C(FASLOAD) IS T
MOVEI B,SBRL ;THEN USE (SUBR LSUBR FSUBR)
HRRZ A,(P) ;IS PROPERTY BEING DEFINED ONE OF INTEREST?
PUSHJ P,MEMQ1
JUMPE A,LDNRDF ;NOPE, SO PRINT NO MESSAGES
MOVE B,VFASLOAD
CAIN B,TRUTH ;IF C(FASLOAD) IS T
MOVEI B,SBRL ;THEN USE (SUBR LSUBR FSUBR)
HRRZ A,-1(P) ;ATOM THAT IS BEING HACKED
PUSHJ P,GETL ;DID THIS PREVIOUSLY HAVE A PROP OF INTEREST?
JUMPE A,LDNRDF ;NOPE, NO MESSAGES TO BE PRINTED
PUSH P,A
PUSH FXP,AR1
PUSH FXP,R
PUSH FXP,F
MOVEI A,TRUTH
JSP T,SPECBIND
0 A,V%TERPRI
STRT 17,[SIXBIT \↑M;CAUTION#! !\]
MOVE A,-2(P)
PUSHJ P,MSGFCK
TLO AR1,200000
PUSHJ P,$PRIN1 ;SAVES AR1
HRRZ B,@(P)
HLRZ B,(B)
MOVEI TT,[SIXBIT \, A SYSTEM !\]
10% CAIL B,ENDFUN
10$ CAIGE B,BEGFUN
MOVEI TT,[SIXBIT \, A USER !\]
STRT 17,(TT)
HLRZ A,@(P)
PUSHJ P,$PRIN1 ;AR1 IS STILL GOOD
HRRZ TT,@(P)
HLRZ TT,(TT)
MOVEI T,(TT)
LSH T,-SEGLOG
HRRZ T,ST(T)
CAIE T,QRANDOM
JRST LDENT4
STRT 17,[SIXBIT \ AT !\] ;USE OF PRINL4 HERE DEPENDS ON PRIN1
PUSHJ P,PRINL4 ; LEAVING ADDRESS OF TYO IN R (AND FILES IN AR1)
LDENT4: STRT 17,[SIXBIT \, IS BEING REDEFINED↑M; AS A !\]
HRRZ A,-1(P)
PUSHJ P,$PRIN1
STRT 17,[SIXBIT \ BY FASL FILE !\]
MOVE A,LDFNAM
PUSHJ P,$PRIN1
PUSHJ P,TERP1
PUSHJ P,UNBIND
POP FXP,F
POP FXP,R
POP FXP,AR1
SUB P,R70+1
LDNRDF: MOVE B,(P)
MOVE A,-1(P)
PUSHJ P,REMPROP
POP P,C
MOVE A,(P)
JSP T,LDGTWD
PUSH FXP,TT
MOVEI B,@LDOFST
CAILE B,(R)
JSP D,LDFERR
PUSHJ P,PUTPROP
POP FXP,TT
HLRZ T,TT
HLRZ B,@(P)
HLRZ D,1(B)
CAIN D,(T) ;NEEDN'T DO IT IF ALREADY SAME
JRST LDPRG3
LDPARG: ;ELSE TRY TO CLOBBER IT IN
PURTRAP LDPRG9,B, HRLM T,1(B)
LDPRG3: SUB P,R70+1
JRST LDBIN
;LDPUT LDPUT7 LDPUT0 LDPUT4 LDPUT5 LDPUTM
SUBTTL PUTDDTSYM FROM FASL FILE
;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS:
;;; 4.9 1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE
;;; 4.8 LH IS RELOCATABLE
;;; 4.7 RH IS RELOCATABLE
;;; 4.6 IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT)
IFN ITS,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3 ;FORGET IT IF "SYMBOLS" IS ()
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000 ;IF "SYMBOLS" IS BOUND TO "SYMBOLS", THEN
JRST LDPUT3 ; LOAD ONLY GLOBALS
LDPUT7: JUMPL TT,LDPUT2
MOVEI D,(R)
LDPUT0: TLZ TT,740000
TLO TT,%SYGBL
SKIPG A,LDDDTP(P)
JRST LDBIN ;FORGET IT IF DDT HAS NO SYMBOL TABLE
MOVE T,TT
TRNE A,-1 ;MAY HAVE TO CREATE SYMBOL TABLE ARRAY
JRST LDPUT5
UNLOCKI
PUSH FXP,AR1
PUSHJ P,SAVX5
MOVEI TT,LLDSTB*2+1
MOVSI A,-1
PUSHJ P,MKFXAR
PUSHJ P,RSTX5
POP FXP,AR1
PUSHJ P,LDLRSP
HRRM A,LDDDTP(P)
LDPUT4: MOVSI TT,-LLDSTB ;USE TT FOR TWO THINGS HERE!
MOVEM TT,@TTSAR(A)
LDPUT5: SETZ TT,
AOS TT,@TTSAR(A) ;GET AOBJN POINTER
JUMPGE TT,LDPUT4
MOVEM T,@TTSAR(A) ;SAVE SQUOZE FOR SYMBOL
ADD TT,R70+1
MOVEM D,@TTSAR(A) ;SAVE ITS VALUE
MOVE T,TT
SETZ TT,
MOVEM T,@TTSAR(A) ;SAVE BACK INCREMENTED AOBJN PTR
JUMPL T,LDBIN
PUSHJ P,LDPUTM ;MAY BE TIME TO OUTPUT BUFFER
JRST LDBIN
LDPUTM: SETZ TT,
MOVN T,@TTSAR(A)
MOVSI T,(T)
HRR T,TTSAR(A)
AOSGE T
.BREAK 12,[..SSTB,,T]
POPJ P,
] ;END OF IFN ITS
;LDPUT LDPUT7 LDPUT0 LDPUT1 LDPUT2 LDPT2A LDPT2B LDPUT3 LDLOC LDLOC5
IFN D10,[
LDPUT: SKIPN A,V$SYMBOLS
JRST LDPUT3
CAIE A,Q$SYMBOLS
JRST LDPUT7
TLNN TT,40000
JRST LDPUT3
LDPUT7: SKIPN .JBSYM"
JRST LDPUT3
PUSH FXP,AR1
JUMPL TT,LDPUT2
MOVE D,R
LDPUT0: PUSH FXP,D
PUSH FXP,F
TLZ TT,740000
LDPUT1: MOVE T,TT
IDIVI TT,50
JUMPE D,LDPUT1
MOVEI B,-1(FXP)
MOVSI R,400000
PUSHJ P,PUTDD0
POP FXP,F
SUB FXP,R70+1
POP FXP,R
POP FXP,AR1
JRST LDBIN
] ;END OF IFN D10
IFN ITS+D10,[
LDPUT2: MOVE D,TT
JSP T,LDGTWD
EXCH TT,D
TLNN TT,100000
JRST LDPT2A
MOVE T,LDOFST
ADD T,D
HRRM T,D
LDPT2A: TLNN TT,200000
JRST LDPT2B
HRLZ T,LDOFST
ADD D,T
LDPT2B: TLZ T,740000
TLO T,%SYGBL+%SYHKL ;GLOBAL AND HALF-KILLED
JRST LDPUT0
] ;END OF ITS+D10
20$ WARN [WHAT TO DO ABOUT TOPS-20 LDPUT]
20$ LDPUT:
LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT
JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD
JRST LDBIN
LDLOC: MOVEI TT,@LDOFST
MOVEI D,(R)
CAMLE D,LDHLOC
MOVEM D,LDHLOC
CAMG TT,LDHLOC
JRST LDLOC5
MOVE D,LDHLOC
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRR R,LDHLOC
SETZ TT,
SUB F,R70+1 ;BEWARE THIS BACK-UP CROCK!
ADD AR1,[040000,,]
JRST LDABS
LDLOC5: HRRZ D,LDOFST
CAIGE TT,(D)
JSP D,LDFERR
MOVEI D,(TT)
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRRI R,(TT)
JRST LDBIN
;LDEVAL LDEVL7 LDEV0 LDEV4 LDEV5 LDEV2 LDEV1
SUBTTL EVALUATE MUNGEABLE
LDEVAL: SETZ D, ;[EVALUATE MUNGEABLE]
PUSHJ P,LDLIST ;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE
MOVEI B,(P) ;B HAS ADDR OF FASLOAD TEMPS ON STACK
PUSH P,A
PUSHJ P,LDEV0
SUB P,R70+1
JUMPN D,LDBIN
JSP T,LDQLPRO ;PUSHES GOODY ONTO THE LDEVPRO LIST
LDEVL7: TLO A,16 ;AND GOES OFF TO ENTER INTO THE ATOMTABLE
JRST LDATP8
LDEV0: UNLOCKI ;EVALUATES AN S-EXPRESSION IN A
JUMPE D,LDEV2 ;ALLOWS FOR RECURSIVE FASLOADING
SETZM FASLP ;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE
PUSH P,A
MOVE C,LDPRLS(B)
TLNN C,600000
HRRZM C,VPURCLOBRL
IFN D10*HISEGMENT,[
TLNN C,100000
JRST LDEV4
HRRZM R,HBPORG
JRST LDEV5
LDEV4:
] ;END OF IFN D10*HISEGMENNT
MOVEI TT,(R)
JSP T,FXCONS
MOVEM A,VBPORG
LDEV5: HRRZ TT,LDOFST ;IN CASE EVALUATION CHANGES BPORG,
SUBI TT,(R) ; MUST CHANGE LDOFST TO BE AN
HRRM TT,LDOFST ; ABSOLUTE QUANTITY
MOVNI T,LFTMPS
PUSH FXP,BFTMPS+LFTMPS(T)
AOJL T,.-1
POP P,A
LDEV2:
PUSH FXP,B
PUSH FXP,AR1
PUSH FXP,D
PUSH FXP,R
PUSH FXP,F
PUSHJ P,EVAL
POP FXP,F
POP FXP,R
POP FXP,D
POP FXP,AR1
POP FXP,B
JUMPE D,LDEV1
HS$ 10$ MOVE C,LDPRLS(B)
HS$ 10$ TLNE C,100000
HS$ 10$ SKIPA R,HBPORG
MOVE R,@VBPORG
HRRZ T,LDBGEN(B)
MOVEM T,FASLP
MOVEI T,LFTMPS-1
POP FXP,BFTMPS(T)
SOJGE T,.-1
HRRZ TT,LDOFST ;NOW RE-RELOCATE THE LOAD OFFSET
ADDI TT,(R)
HRRM TT,LDOFST
HRRZ T,VPURCLOBRL
HRRM T,LDPRLS(B)
LDEV1: PUSH P,A
10$ MOVE TT,LDPRLS(B) ;FOR D10, PASS LDPRLS IN TT TO LDGTSP
PUSHJ P,LDGTSP
POP P,A
JRST LDLRSP ;GET SPACE, LOCKI, AND RESTORE PTRS
;LDBEND LDBEN1 LDFEND LDFEN2 LDFEN3 LDNPUR LDZPUR
SUBTTL END OF FASLOAD FILE
LDBEND: TRZ TT,1 ;CROCK!
CAME TT,[SIXBIT \*FASL*\]
JSP D,LDFERR
MOVEI TT,LDFEND
MOVEM TT,LDEOFJ
IFN ITS,[
SKIPLE A,LDDDTP(P)
TRNN A,-1
CAIA
PUSHJ P,LDPUTM ;MAYBE HAVE TO FORCE LDPUT'S BUFFER
] ;END OF IFN ITS
HLLZS LDDDTP(P) ;WILL USE FOR SWITCH LATER
JSP T,LDGTWD
TRZ TT,1 ;COMPATIBILITY CROCK
CAME TT,[SIXBIT \*FASL*\]
JRST LDBEN1
HLLOS LDDDTP(P)
MOVEM F,LDTEMP
JRST LDFEND
LDBEN1: TRZ TT,1
CAME TT,[14060301406]
10% JSP D,LDFERR
10$ JUMPN TT,LDFERR
LDFEND: TLZ R,-1 ;END OF FILE
CAMGE R,LDHLOC
MOVE R,LDHLOC
HRRZS TT,R
IFE PAGING,[
MOVE C,LDPRLS(P)
TLNN C,100000
JRST LDFEN2
HRRZM R,HBPORG
JRST LDFEN3
LDFEN2: JSP T,FXCONS
MOVEM A,VBPORG
LDFEN3:
] ;END OF IFE PAGING
IFN PAGING,[
JSP T,FXCONS
MOVE D,(A)
EXCH A,VBPORG
MOVE TT,(A)
SKIPL LDPRLS(P)
JRST LDZPUR
HLLOS NOQUIT
ANDI TT,PAGMSK
ANDI D,PAGMSK
LSHC TT,-PAGLOG
SUBI D,(TT)
ROT TT,-4
ADDI TT,(TT)
ROT TT,-1
TLC TT,770000
ADD TT,[450200,,PURTBL]
MOVEI T,1
LDNPUR: TLNN TT,730000
TLZ TT,770000
IDPB T,TT
SOJGE D,LDNPUR
PUSHJ P,CZECHI
LDZPUR:
] ;END OF IFN PAGING
;FALLS THROUGH
;LDGCPR LDGCP1
;FALLS IN
PUSH FXP,F ;SAVE POINTER TO I/O BUFFER
HRRZ F,LDAAOB
LDGCPR: SOJLE F,LDSDPL ;[GC PROTECT AS YET UNPROTECTED ATOMS]
SKIPE INTFLG
PUSHJ P,LDTRYI
MOVEI TT,(F)
MOVE AR2A,@LDAPTR
HRRZ A,AR2A
JUMPE A,LDGCPR ;LOSING MIDAS!
TLNE AR2A,777000 ;WAS VALUE CELL CREATED BY FASLOAD?
JRST LDGCPR ;YES, THEN NO NEED TO HACK IT AT ALL
TLNN AR2A,6
JRST LDGCPR ;NOT NUMBER, HACKED ALREADY
TLNN AR2A,10
TLNN AR2A,1
JRST LDGCPR
LDGCP1: HRRZ A,AR2A
CAIGE A,IN0+XHINUM
CAIGE A,IN0-XLONUM
CAIA
JRST LDGCPR
;IF FOR SOME REASON, THIS CAUSES THE CREATION OF THE GCPSAR
; I STILL DONT THINK WE NEED TO RESTORE PTRS HERE.
;I DISAGREE, SO I'M STICKING IN A CALL TO LDRSPT - GLS
PUSHJ P,%GCPRO
PUSHJ P,LDRSPT
JRST LDGCPR
;LDSDPL LDSDP1 LDSDP2 LDSDP3
SUBTTL SMASH DOWN PURE LIST
LDSDPL: SKIPL TT,LDPRLS(P) ;[SMASH DOWN PURE LIST]
TLNE TT,200000
JRST LDEOMM
MOVEM TT,VPURCLOBRL
MOVEI F,VPURCLOBRL
LDSDP1: SKIPN TT,LDPRLS(P)
JRST LDEOMM
SKIPN INTFLG
JRST LDSDP2
SKIPE INTFLG
PUSHJ P,LDTRYI
LDSDP2: HRRZ T,(TT)
MOVEM T,LDPRLS(P)
HLRZ AR2A,(TT)
PUSHJ P,LDSMSH
JRST LDSDP3
HRRZ F,(F)
JRST LDSDP1
LDSDP3: MOVE TT,LDPRLS(P)
HRRM TT,(F)
JRST LDSDP1
;LDEOMM LDEOM1 LDTRYI LDLRSP LDRSPT
SUBTTL END OF FASLOAD, AND RANDOM ROUTINES
LDEOMM: POP FXP,LDTEMP ;GET POINTER TO I/O BUFFER
MOVE TT,LDDDTP(P)
MOVE A,LDBGEN(P)
10$ MOVE C,LDPRLS(P)
POPI P,LDNPDS ;[END OF MOBY MESS!!!]
TRNE TT,-1
JRST LDEOM1
PUSHJ P,$CLOSE ;CLOSE FILE ARRAY
SETZM LDBSAR
MOVE A,VBPORG
HS$ 10$ MOVE TT,HBPORG
HS$ 10$ TLNE C,100000
HS$ 10$ JSP T,FXCONS
UNLOCKI
PUSHJ P,UNBIND
HRRZ TT,-2(P) ;FOR DEBUGGING PURPOSES,
HRRZ D,-1(P) ; MAKE SURE PDLS ARE OKAY
HRRZ R,(P)
SUB P,R70+3
JRST PDLCHK
LDEOM1: UNLOCKI
PUSH P,A ;PUT LDBSAR BACK ON PDL
JRST LDDISM
LDTRYI: UNLOCKI ;[TRY AN INTERRUPT]
LDLRSP: LOCKI ;[LOCKI AND RESTORE POINTERS]
LDRSPT: HRRZ TT,LDASAR ;[RESTORE ARRAY POINTERS]
HRRZ TT,TTSAR(TT)
HRRM TT,LDAPTR
HRRZ TT,LDBSAR
IFE D10,[
HRRZ TT,TTSAR(TT)
HRRM TT,LDBPTR
] ;END IFE QIO*D10
.ELSE HLLZS LDBPTR
POPJ P,
;LDLIST LDLIS0 LDLIS1 LDLTBL LDLATM LDLLST LDLDLS LDLLS1 LDLLS3 LDOWL LDLHNK LDLEND
LDLIST: MOVEI C,-1(P) .SEE LDOWL
JRST LDLIS1
LDLIS0: JSP T,LDGTWD
LDLIS1: LDB T,[410300,,TT] ;[CONSTRUCT LIST]
JRST LDLTBL(T)
LDLTBL: JRST LDLATM ;ATOM
JRST LDLLST ;LIST
JRST LDLDLS ;DOTTED LIST
JRST LDOWL ;EVALUATE TOP FROB ON STACK
IFN HNKLOG, JRST LDLHNK ;HUNK
.ELSE JRST FASHNE
REPEAT 2, .VALUE
JRST LDLEND ;END OF LIST
LDLATM: MOVE A,@LDAPTR ;FOR ATOM, MAYBE SET USAGE BIT,
TLNN A,777011 ; THEN SHOVE ON STACK
IOR A,D
MOVEM A,@LDAPTR
PUSH P,A
TRNN A,-1
JRST LDLIS0 ;SKIP SY2 CHECK IF SYMBOL 'NIL'
TLNN A,777006 ;IF HAS VALUE CELL, OR IS NUMBER, DON'T DO SY2
TLNN D,1 ;IF SETTING USAGE BIT THEN ALSO DO SO IN SY2
JRST LDLIS0
HLRZ T,(A) ;GET SY2 WORD
HLL T,(T)
TLO T,SY.CCN\SY.OTC ;MUST FLAG ATOM AS NEEDED
TLNN T,SY.PUR ;SET MEMORY UNLESS PURIFIED
HLLM T,(T)
JRST LDLIS0
LDLLST: TDZA A,A ;FOR LIST, USE NIL AS END
LDLDLS: POP P,A ;FOR DOTTED LIST, USE TOP ITEM
HRRZS TT
JUMPE TT,LDLLS3
LDLLS1: POP P,B ;NOW POP N THINGS AND CONS THEM UP
PUSHJ P,XCONS
SOJG TT,LDLLS1
LDLLS3: PUSH P,A
SKIPE INTFLG
PUSHJ P,LDTRYI
JRST LDLIS0
LDOWL: MOVE A,(P)
MOVEI B,(C) ;B HAS ADDR OF FASLOAD TEMPS ON STACK
PUSH P,C
PUSHJ P,LDEV0
POP P,C
MOVEM A,(P)
JRST LDLIS0
IFN HNKLOG,[
LDLHNK: ANDI TT,-1 ;FLUSH LH CONTROL BITS
PUSHJ P,ALHNKL ;(TT) HAS NUMBER OF ITEMS WANTED
PUSH P,A ; POP THEM OFF PDL INTO A HUNK
JRST LDLIS0 ;SAVES C
] ;END OF IFN HNKLOG
LDLEND: HLRZ D,TT
TRC D,777776
TRNE D,777776
JSP D,LDFERR
POP P,A
MOVSS TT
HRRI TT,(A)
POPJ P,
;ZZ ZZZ ZZ ZZZ LDFNM2 LDGTW0 LDGTWD LDGTW1 LDGTW9 LDGTW0 LDGTWD LDGTW1 LDGTE1 LDGTWE LDGTW0 LDGTWD LDGTW1 ALCHAN ALCHN0 ALCHN1 ALCH1A ALCHN2 ALCHN3 ALCHN9
;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER
;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY
;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS
;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS.
;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE
;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY
;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS
;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S.
ZZ==-1
ZZZ==0
;;; BIBOP USED TO BE THE 3RD NUMBER HERE
IRP X,,[D10,ML,1,BIGNUM]
ZZ==ZZ←1
ZZZ==<ZZZ←1>\X
TERMIN
LDFNM2: <.FNAM2&ZZ>\ZZZ
EXPUNGE ZZ ZZZ
IFN ITS,[
LDGTW0: SUB F,FB.BFL(TT)
HRLZI F,(F)
HRRI F,FB.BUF
LDGTWD: MOVE TT,@LDBPTR
AOBJN F,(T)
LDGTW1: HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
PUSH FXP,FB.IBP(TT)
MOVE F,FB.BFL(TT)
SUBI F,1
.CALL LDGTW9
.LOSE 1400
POPI FXP,1
ADDI F,1
CAME F,FB.BFL(TT)
SOJA F,LDGTW0
JSP D,@LDEOFJ
LDGTW9: SETZ
SIXBIT \SIOT\ ;"STRING" I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
,,0(FXP) ;BYTE POINTER
400000,,F ;BYTE COUNT
];END IFN ITS
IFN D20,[
LDGTW0: SUB F,FB.BFL(TT) ;MAKE F INTO AOBJN POINTER
HRLZI F,(F)
HRRI F,FB.BUF ;POINTING INTO THE BUFFER
LDGTWD: AOBJP F,LDGTW1
SUBI F,1 ;READJUST TO ACCESS CORRECT WORD
MOVE TT,@LDBPTR
AOJA F,(T) ;FIXUP AOBJN POINTER THEN RETURN
LDGTW1: HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
PUSHJ FXP,SAV3 ;SAVE ACS WHICH WILL BE DESTROYED
HRRZ 1,F.JFN(TT) ;JFN INTO AC 1
MOVE 2,FB.IBP(TT) ;BYTE POINTER INTO AC 2
MOVN 3,FB.BFL(TT) ;READ THIS MANY BYTES
SIN ;DO THE INPUT
ERJMP LDGTWE ;WE CAN IGNORE ERROR IF IT IS EOF
LDGTE1: MOVN F,3 ;GET POSITIVE NUMBER OF BYTES LEFT UNREAD
PUSHJ FXP,RST3 ;RESTORE SAVED ACS
CAME F,FB.BFL(TT) ;DID WE READ ANYTHING?
SOJA F,LDGTW0 ;YES, SO EMPTY THE BUFFER BEFORE GIVING EOF
JSP D,@LDEOFJ
LDGTWE: MOVEI 1,.FHSLF ;GET OUR LAST ERROR
GETER
HRRZS 2 ;ONLY WANT ERROR CODE
CAIN 2,IOX4 ;EOF?
JRST LDGTE1
MOVEI 1,.PRIOU ;OUTPUT ERROR TO PRIMARY OUTPUT CHANNEL
HRLOI 2,.FHSLF ;LAST ERROR FOR OUR PROCESS
SETZ 3, ;NO LIMIT TO AMOUNT OF OUTPUT
ERSTR
.LOSE ;FAILED
.LOSE ;FAILED
PUSHJ FXP,RST3 ;RESTORE SAVED AC'S
JSP D,@LDEOFJ ;MAKE BELIEVE WE HIT EOF
] ;END IFN D20
IFN D10,[
LDGTW0: POP P,T
MOVE TT,FB.HED(TT) ;GET BUFFER HEADER ADDRESS
MOVN F,2(TT) ;NUMBER OF WORDS IN BUFFER
HRLZI F,-1(F)
ADDI F,1 ;NOW THE ACTUAL FIRST WORD
LDGTWD: MOVE TT,LDBSAR ;GET POINTER TO SAR
HRRZ TT,TTSAR(TT)
MOVE TT,FB.HED(TT) ;GET POINTER TO BUFFER HEADER
HRRZ TT,1(TT) ;GET FIRST WORD OF BUFFER - 1
HRLI TT,F ;INDEXED OFF OF F
MOVE TT,@TT
AOBJN F,(T)
LDGTW1: HRRZ TT,LDBSAR
HRRZ TT,TTSAR(TT)
PUSH P,T
HRLZ T,F.CHAN(TT) ;WE MUST BUILD INSTRUCTION
LSH T,5 ;CHANNEL IN AC FIELD
TLO T,(IN) ;NOW MAKE IT AN INSTRUCTION
XCT T ;GET AS MANY WORDS AS POSSIBLE
JRST LDGTW0 ;IF SUCCESS THEN SETUP NEW POINTERS
POP P,T
JSP D,@LDEOFJ
] ;END IFN D10
PGTOP FSL,[FASLOAD]
;;@ END OF FASLOA 223
;;@ QIO 585 NEW MULTIPLE FILE I/O FUNCTIONS
;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** NEW MULTIPLE FILE I/O FUNCTIONS *********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT [QIO]
SUBTTL I/O CHANNEL ALLOCATOR
;;; ALCHAN ALLOCATES AN I/O CHANNEL FOR USE.
;;; THE "CHANNEL NUMBER" IS AN INDEX INTO THE CHANNEL TABLE.
.SEE CHNTB
;;; FOR ITS AND DEC10, THIS IS ALSO THE CHANNEL NUMBER USED TO
;;; COMMUNICATE WITH THE TIMESHARING SYSTEM. (FOR DEC20, A
;;; SEPARATE JFN MUST BE ALLOCATED WITH THE GTJFN JSYS.)
;;; ALCHAN EXPECTS THE SAR FOR THE FILE ARRAY TO BE IN A,
;;; AND RETURNS THE CHANNEL NUMBER IN F, SKIPPING IF SUCCESSFUL.
;;; THE FILE ARRAY MUST HAVE ITS TTS.CL BIT SET.
;;; THE CHANNEL NUMBER IS INSTALLED IN THE FILE'S F.CHAN SLOT.
;;; USER INTERRUPTS TURNED OFF, PLEASE. CLOBBERS R.
;;; MAY INVOKE A GARBAGE COLLECTION TO FREE UP CHANNELS.
ALCHAN: HRRZS (P)
ALCHN0: MOVNI F,LCHNTB-2 ;SCAN CHANNEL TABLE
ALCHN1: SKIPN R,CHNTB+LCHNTB-1(F)
JRST ALCHN3 ;FOUND A FREE CHANNEL
JUMPL R,ALCH1A ;NEGATIVE, RESERVED
MOVE R,TTSAR(R)
TLNE R,TTS<CL>
JRST ALCHN2 ;SEMI-FREE
ALCH1A: AOJLE F,ALCHN1 ;DON'T CHECK CHANNEL 0 (NEVER FREE)
SKIPGE (P) ;SKIP IF FIRST TIME
POPJ P, ;LOSEY LOSEY
HRROS (P) ;SET SWITCH
PUSH P,[555555,,ALCHN0]
JRST AGC ;HOPE GC WILL RECLAIM A FILE ARRAY
ALCHN2: MOVEI F,LCHNTB-1(F)
IT$ .CALL ALCHN9 ;CLOSE CHANNEL TO BE SURE
IT$ .LOSE 1400
IFN D10,[
MOVEI R,(F)
LSH R,27
IOR R,[RELEASE 0,0] ;RELEASE CHANNEL TO BE SURE
XCT R
] ;END OF IFN D10
SKIPA
ALCHN3: MOVEI F,LCHNTB-1(F)
MOVE R,TTSAR(A) ;INSTALL CHANNEL NUMBER
MOVEM F,F.CHAN(R)
MOVEM A,CHNTB(F) ;RESERVE CHANNEL
JRST POPJ1 ;WIN WIN - SKIP RETURN
IFN ITS,[
ALCHN9: SETZ
SIXBIT \CLOSE\ ;CLOSE I/O CHANNEL
400000,,F ;CHANNEL #
] ;END OF IFN ITS
;ALFILE UNLKPJ
;;; ALFILE CREATES A MINIMAL FILE ARRAY (OF LENGTH LOPOFA),
;;; AND ALLOCATES A CHANNEL FOR IT. IT EXPECTS A DEVICE NAME
;;; IN TT (FOR DEC20, TT AND D) WHICH IS INSTALLED IN THE
;;; F.DEV AND F.RDEV SLOTS OF THE FILE ARRAY.
;;; THIS IS USEFUL FOR ROUTINES WHICH WANT TO HACK ON A
;;; RANDOM CHANNEL BUT DON'T NEED A FULL-BLOWN FILE ARRAY.
;;; A FILE ARRAY IS NEEDED FOR THE SAKE OF THE CHANNEL TABLE
.SEE CHNTB
;;; AND FOR THE GARBAGE COLLECTOR; IF THE FILE ARRAY IS
;;; GARBAGE COLLECTED, SO IS THE ASSOCIATED CHANNEL.
;;; THE FILE ARRAY ALSO MUST CONTAIN AT LEAST A DEVICE
;;; NAME SO PRIN1 CAN WIN.
.SEE PRNFL
;;; CLOBBERS PRACTICALLY ALL ACS.
;;; THE ARRAY GC POINTER IS SET TO PROTECT THE FIRST SLOT ONLY.
;;; RETURNS FILE ARRAY IN A, CHANNEL NUMBER IN F.
;;; SKIPS ON SUCCESS; FAILS IF ALCHAN CAN'T GET A CHANNEL.
ALFILE: LOCKI
PUSH FXP,TT
MOVEI TT,LOPOFA ;LENGTH OF PLAIN OLD FILE ARRAY
MOVSI A,-1 ;GET ONLY A SAR
PUSHJ P,MKLSAR
MOVSI TT,TTS<CL> ;SET CLOSED BIT
IORB TT,TTSAR(A)
MOVSI T,AS<FIL> ;SET FILE ARRAY BIT (MUST DO
IORB T,ASAR(A) ; IN THIS ORDER!)
HRROS -1(T) ;GC SHOULD PROTECT ONLY ONE SLOT
POP FXP,T
MOVEM T,F.DEV(TT) ;INSTALL DEVICE NAME
20% MOVEM T,F.RDEV(TT)
MOVSI T,FBT.CM ;PREVENT GC FROM TRYING TO
MOVEM T,F.MODE(TT) ; UPDATE NONEXISTENT POINTERS
PUSHJ P,ALCHAN
JRST UNLKPJ
AOS (P) ;WE SKIP IFF ALCHAN DOES
MOVSI TT,TTS<CL>
ANDCAM TT,TTSAR(A)
UNLKPJ: UNLKPOPJ
;AFILEP XFILEP FILEP AFOSP XFOSP
SUBTTL FILE OBJECT CHECKING ROUTINES
;;; JSP TT,XFILEP
;;; SKIPS IFF THE OBJECT IN AR1 IS A FILE ARRAY. CLOBBERS R.
SFA% AFOSP:
AFILEP: MOVEI AR1,(A)
SFA% XFOSP:
XFILEP: MOVEI R,(AR1)
LSH R,-SEGLOG
MOVE R,ST(R)
TLNN R,SA
JRST (TT)
MOVE R,ASAR(AR1) ;MUST ALSO HAVE FILE BIT SET
TLNN R,AS<FIL>
JRST (TT)
JRST 1(TT)
FILEP: JSP TT,AFILEP ;SUBR 1
JRST FALSE
JRST TRUE
IFN SFA,[
; PARALLEL TOO AFILEP/XFILEP BUT SKIPS ONCE FOR FILE-OBJECT, AND TWICE
; FOR SFA-OBJECT
AFOSP: MOVEI AR1,(A)
XFOSP: MOVEI R,(AR1)
LSH R,-SEGLOG
MOVE R,ST(R)
TLNN R,SA ;MUST BE A SAR
JRST (TT)
MOVE R,ASAR(AR1) ;DOES IT HAVE FILE BIT SET?
TLNE R,AS<FIL>
JRST 1(TT) ;YES, SINGLE SKIP
TLNE R,AS.SFA ;AN SFA?
JRST 2(TT) ;YES, DOUBLE SKIP
JRST (TT) ;ELSE ERROR RETURN
] ;END IFN SFA
;OFILOK IFILOK ATFLOK ATOFOK ATIFOK TFILOK TIFLOK TOFLOK XIFLOK XOFLOK FILOK NFILE FILOK0 FILOK1 FILNOK
;;; THESE ROUTINES ACCEPT A FILE ARRAY IN AR1 AND CHECK WHETHER
;;; IT IS OF THE DESIRED TYPE. IF NOT, A WTA ERROR OCCURS.
;;; LEAVES TTSAR IN TT AND USER INTS LOCKED IF SUCCESSFUL.
;;; CLOBBERS T, TT, AND R. SAVES D (SEE FILEPOS) AND F.
OFILOK: JSP T,FILOK0 ;TYPICAL INVOCATION:
TTS<IO>,,TTS<IO> ; DESIRED BITS,,MASK
SIXBIT \NOT OUTPUT FILE!\ ; ERROR MSG IF FAIL
IFILOK: JSP T,FILOK0
0,,TTS<IO>
SIXBIT \NOT INPUT FILE!\
ATFLOK: JSP T,FILOK0
0,,TTS<BN>
SIXBIT \NOT ASCII FILE!\
ATOFOK: JSP T,FILOK0
TTS<IO>,,TTS<BN+IO>
SIXBIT \NOT ASCII OUTPUT FILE!\
ATIFOK: JSP T,FILOK0
0,,TTS<BN+IO>
SIXBIT \NOT ASCII INPUT FILE!\
TFILOK: JSP T,FILOK0
TTS<TY>,,TTS<TY>
SIXBIT \NOT TTY FILE!\
TIFLOK: JSP T,FILOK0
TTS<TY>,,TTS<TY+IO>
SIXBIT \NOT TTY INPUT FILE!\
TOFLOK: JSP T,FILOK0
TTS<TY+IO>,,TTS<TY+IO>
SIXBIT \NOT TTY OUTPUT FILE!\
XIFLOK: JSP T,FILOK0
TTS<BN>,,TTS<IM+BN+IO>
SIXBIT \NOT BINARY INPUT FILE!\
XOFLOK: JSP T,FILOK0
TTS<BN+IO>,,TTS<IM+BN+IO>
SIXBIT \NOT BINARY OUTPUT FILE!\
FILOK: JSP T,FILOK0
0,,0
NFILE: SIXBIT \NOT FILE!\
FILOK0: LOCKI
CAIE AR1,TRUTH ;T => TTY FILE ARRAY
JRST FILOK1
MOVSI TT,TTS<IO>
TSNE TT,(T) ;IF DON'T CARE ABOUT I/O
TDNE TT,(T) ; OR SPECIFICALLY WANT OUTPUT
SKIPA AR1,V%TYO ; THEN USE TTY OUTPUT
HRRZ AR1,V%TYI ;USE TTY INPUT ONLY IF NECESSARY
FILOK1: JSP TT,XFILEP ;SO IS IT A FILE ARRAY?
JRST FILNOK ;NOPE - LOSE
MOVE TT,TTSAR(AR1)
XOR TT,(T)
HLL T,TT
MOVE TT,TTSAR(AR1) ;WANT TO RETURN TTSAR IN TT
TLNE T,@(T)
JRST FILNOK
TLNN TT,TTS<CL>
POPJ P, ;YEP - WIN
SKIPA TT,[[SIXBIT \FILE HAS BEEN CLOSED!\]]
FILNOK: MOVEI TT,1(T)
EXCH A,AR1
UNLOCKI
%WTA (TT)
EXCH A,AR1
JRST FILOK0
;NML6BT NML6B5 NML6BZ NML6B0 NML6B2 NML6FN NML6UF NML6F5 NML6F2 NML6F4 NML6F3 NML6DV NML6PP NML6P2 NML6D1 NML6D8 NML6D7 NML6D4 NML6P1 NML6P3 SARGHT IDND IDND IDNTB LIDNTB IDND IDND1 IDND2 IDND3 IDNDLS
SUBTTL CONVERSION: NAMELIST => SIXBIT
;;; A NAMELIST IN A IS CONVERTED TO "SIXBIT" FORMAT ON THE FIXNUM PDL.
;;; "SIXBIT" FORMAT IS ACTUALLY SIXBIT FOR SOME OPERATING SYSTEMS,
;;; BUT MAY BE ANY ANY FORM WHATSOEVER AS LONG AS ALL ROUTINES WHICH
;;; CLAIM TO UNDERSTAND "SIXBIT" FORM AGREE ON WHAT THAT FORM IS.
;;; (SOME ROUTINES WHICH DO I/O DEPEND ON THIS FORMAT, FOR EXAMPLE
;;; ITS ROUTINES WHICH USE THE OPEN SYMBOLIC SYSTEM CALL.)
;;; "SIXBIT" FORMAT IS DEFINED AS FOLLOWS:
;;;
;;; FOR ITS: <SIXBIT DEVICE NAME>
;;; <SIXBIT SNAME>
;;; <SIXBIT FILE NAME 1>
;;; <SIXBIT FILE NAME 2> ;TOP OF STACK
;;; AN OMITTED COMPONENT CAN BE REPRESENTED BY EITHER A ZERO
;;; WORD OR SIXBIT \*\ (THE LATTER BEING THE CANONICAL CHOICE).
;;;
;;; FOR DEC10: <SIXBIT DEVICE NAME>
;;; <PROJ-PROG NUMBER>
;;; <SIXBIT FILE NAME>
;;; <SIXBIT EXTENSION> ;TOP OF STACK
;;; AN OMITTED COMPONENT CAN BE REPRESENTED BY EITHER A ZERO
;;; WORD OR SIXBIT \*\ (THE LATTER BEING THE CANONICAL CHOICE),
;;; EXCEPT FOR THE PPN, FOR WHICH 777777 INDICATES AN OMITTED HALFWORD.
;;;
;;; FOR DEC20: <ASCIZ DEVICE OR LOGICAL NAME>
;;; <ASCIZ DIRECTORY NAME>
;;; <ASCIZ FILE NAME>
;;; <ASCIZ EXTENSION/TYPE NAME>
;;; <ASCIZ VERSION/GENERATION> ;TOP OF STACK
;;; THE ENTRIES HERE ARE NOT SINGLE WORDS, BUT ARE OF
;;; RESPECTIVE LENGTHS (IN WORDS) L.6DEV, L.6DIR, L.6FNM,
;;; L.6EXT, L.6VRS.
;;;
;;; NOTE THAT FOR ALL SIXBIT FORMATS THE TOTAL LENGTH OF THE
;;; SIXBIT FORMAT IS L.F6BT. THIS DIVIDES INTO TWO PARTS:
;;; THE DEVICE/DIRECTORY, OF LENGTH L.D6BT, AND THE FILE NAME
;;; PROPER, OF LENGTH L.N6BT.
;;;
;;; THERE ARE FOUR KINDS OF FILE NAME SPECIFICATIONS.
;;; ONE IS A FILE OBJECT, WHICH IMPLIES THE NAME USED TO OPEN IT.
;;; ONE IS AN ATOMIC SYMBOL, WHICH IS TREATED AS A NAMESTRING.
;;; THE OTHER TWO ARE NAMELISTS, UREAD-STYLE AND NEWIO-STYLE.
;;; NEWIO-STYLE NAMELISTS HAVE NON-ATOMIC CARS, WHILE UREAD-STYLE
;;; NAMELISTS HAVE ATOMIC CARS. UREAD-STYLE NAMELISTS ARE MOSTLY
;;; FOR COMPATIBILITY WITH OLDIO, AND FOR USER CONVENIENCE.
;;;
;;; IN A NEWIO-STYLE NAMELIST, THE CAR IS A DEVICE/DIRECTORY
;;; SPECIFICATION, AND THE CDR A FILE NAME SPECIFICATION.
;;; IN PRINCIPLE EACH IS A LIST OF ARBITRARY LENGTH.
;;; IN PRACTICE, THERE IS A LIMIT FOR EACH OF THE PDP-10
;;; IMPLEMENTATIONS. THE CANONICAL NAMELIST FORMAT FOR
;;; EACH SYSTEM IS AS FOLLOWS:
;;; ITS: ((<DEVICE> <SNAME>) <FILE NAME 1> <FILE NAME 2>)
;;; TOPS10: ((<DEVICE> (<PROJ#> <PROG#>)) <FILE NAME> <EXTENSION>)
;;; SAIL: ((<DEVICE> (<PROJ> <PROG>)) <FILE NAME> <EXTENSION>)
;;; CMU: ((<DEVICE> <PPN>) <FILE NAME> <EXTENSION>)
;;; CMU ALSO ALLOWS TOPS10-STYLE NAMELISTS.
;;; TENEX: ((<DEVICE> <DIRECTORY>) <FILE NAME> <EXTENSION> <VERSION>)
;;; TOPS20: ((<DEVICE> <DIRECTORY>) <FILE NAME> <TYPE> <GENERATION>)
;;;
;;; ALL COMPONENTS ARE NOMINALLY ATOMIC SYMBOLS, EXCEPT <PROJ#> AND <PROG#>,
;;; WHICH ARE FIXNUMS. IF THE USER SUPPLIES A COMPONENT WHICH IS NOT
;;; A SYMBOL (AND IT CAN EVEN BE NON-ATOMIC IF THERE IS NO AMBIGUITY
;;; AS TO FORMAT), THEN IT IS EXPLODEC'D WITH BASE=10., PRINLEVEL=PRINLENGTH=NIL,
;;; AND *NOPOINT=T. A COMPONENT MAY BE "OMITTED" BY USING THE ATOMIC
;;; SYMBOL *. THIS DOES NOT MEAN A WILDCARD, BUT ONLY AN OMITTED COMPONENT.
;;;
;;; IF THE USER SUPPLIES A NAMELIST NOT IN CANONICAL FORM, THE CAR AND CDR
;;; ARE INDEPENDENTLY CANONICALIZED. THE CAR CAN BE ACANONICAL ONLY BY
;;; BEING A SINGLETON LIST; IN THIS CASE AN ATTEMPT IS MADE TO DECIDE
;;; WHETHER IT IS A DEVICE OR DIRECTORY SPECIFICATION. THIS IS DONE IN
;;; DIFFERENT WAYS ON DIFFERENT SYSTEMS. ON TOPS10, FOR EXAMPLE, AN ATOMIC
;;; SPECIFICATION IS NECESSARY A DEVICE AND NOT A PPN. ON THE OTHER HAND,
;;; ON ITS A LIST OF STANDARD DEVICE NAMES IS CHECKED.
;;; THE CDR CAN BE ACANONICAL BY BEING TOO SHORT, OR BY BEING A DOTTED LIST,
;;; OR BOTH. COMPONENTS ARE TAKEN IN ORDER UNTIL AN ATOMIC CDR IS REACHED.
;;; IF THIS CDR IS NIL, ALL REMAINING COMPONENTS ARE TAKEN TO BE *.
;;; OTHERWISE, ALL REMAINING COMPONENTS ARE * EXCEPT THE LAST, WHICH IS
;;; THAT ATOM IN THE CDR.
;;;
;;; A UREAD-STYLE NAMELIST IS NOMINALLY IN THE FORM (A B C D), WHERE
;;; A, AT LEAST, MUST BE ATOMIC. IT IS INTERPRETED AS IF IT WERE CONVERTED
;;; TO THE FORM ((C D) A B) [DEC20: ((C D) A * B)], AND THEN TREATING IT AS
;;; AN ORDINARY NAMELIST. (IF C AND D ARE MISSING, THEN (*) IS USED INSTEAD
;;; OF NIL AS THE CAR OF THE CONSTRUCTED NAMELIST.
NML6BT: JSP T,QIOSAV ;SAVE REGISTERS
NML6B5: PUSH P,A
HLRZ A,(A) ;CHECK CAR OF NAMELIST
JSP T,STENT
JUMPGE TT,NML6B2 ;JUMP IF UREAD-STYLE NAMELIST
PUSHJ P,NML6DV ;CONVERT DEVICE/DIRECTORY SPECIFICATION
JRST NML6B0 ;SKIPS UNLESS CONVERSION FAILED
HRRZ A,@(P)
PUSHJ P,NML6FN ;CONVERT FILE NAMES (LEAVES TAIL IN A)
JUMPE A,POP1J ;SUCCEED UNLESS TOO MANY FILE NAMES
NML6BZ: POPI FXP,L.N6BT ;POP FILE NAME CRUD
NML6B0: POPI FXP,L.D6BT ;POP DEVICE/DIRECTORY CRUD
POP P,A ;POP ORIGINAL ARGUMENT
WTA [INCORRECTLY FORMED NAMELIST!]
JRST NML6B5
NML6B2: HRRZ A,(P) ;HERE FOR UREAD-STYLE NAMELIST
PUSHJ P,NML6UF ;CONVERT FILE NAMES, BUT AT MOST TWO OF THEM
PUSHJ P,NML6DV ;NOW CONVERT THE DEVICE/DIRECTORY
JRST NML6BZ ;NOTE THAT POPI'S COMMUTE AT NML6BZ!
;AT THIS POINT THE WORDS ON FXP ARE IN THE WRONG ORDER, SO WE SHUFFLE THE STACK.
IFN ITS+D10,[
POP FXP,TT ;DIRECTORY
POP FXP,T ;DEVICE
EXCH T,-1(FXP) ;EXCH DEVICE WITH FN1
EXCH TT,(FXP) ;EXCH DIR WITH FN2
PUSH FXP,T ;PUSH FN1
PUSH FXP,TT ;PUSH FN2
] ;END OF IFN ITS+D10
IFN D20,[
MOVEI T,-L.F6BT+1(FXP)
HRLI T,-L.N6BT
PUSH FXP,(T) ;COPY THE FILE NAMES TO THE TOP
AOBJN T,.-1 ; OF THE STACK
MOVEI T,-L.F6BT-L.N6BT+1(FXP)
HRLI T,-L.F6BT+1(FXP)
BLT T,-L.N6BT(FXP) ;COPY ENTIRE "SIXBIT" SET DOWNWARD
POPI FXP,L.N6BT ;POP OFF EXTRANEOUS CRUD
] ;END OF IFN D20
JRST POP1J
;;; CONVERT FILE NAME LIST IN A TO "SIXBIT" FORM ON FXP.
;;; RETURNS THE UNUSED TAIL OF THE LIST IN A.
;;; NML6UF IS LIKE NML6FN, BUT NEVER GOBBLES MORE THAN TWO NAMES.
NML6FN:
20$ TDZA T,T
NML6UF:
20$ SETO T, ;UREAD-STYLE DISTINCTION ONLY MATTERS TO DEC20
20$ HRLM T,(P)
20$ PUSHN FXP,L.N6BT ;PUSH ROOM FOR THE FILE NAMES
20% REPEAT 2, PUSH FXP,[SIXBIT \*\] ;PUSH ROOM FOR THE FILE NAMES
JUMPE A,CPOPJ ;NULL LIST => ALL NAMES OMITTED
PUSH P,A
JSP T,STENT
JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT
HLRZ A,(A)
20% PUSHJ P,SIXMAK ;CONVERT FIRST COMPONENT TO SIXBIT,
20% MOVEM TT,-1(FXP) ; AND CALL IT FILE NAME 1
IFN D20,[
PUSHJ P,PNBFMK ;CONVERT FIRST COMPONENT TO ASCIZ,
MOVEI T,-L.6FNM-L.6EXT-L.6VRS+1(FXP) ; AND CALL IT THE FILE NAME
HRLI T,PNBUF
BLT T,-L.6EXT-L.6VRS(FXP)
MOVEI T,177←1 ;MASK FOR LAST BYTE IN AN ASCII WORD
ANDCAM T,-L.6EXT-L.6VRS(FXP) ;MAKE SURE LAST BYTE IS NULL
] ;END OF IFN D20
HRRZ A,@(P)
JUMPE A,POP1J ;EXIT IF ALL DONE
MOVEM A,(P)
IFN D20,[
JSP T,STENT
JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT
HLRZ A,(A)
PUSHJ P,PNBFMK ;CONVERT NEXT COMPONENT TO ASCIZ,
MOVEI T,-L.6EXT-L.6VRS+1(FXP) ; AND CALL IT THE EXTENSION
HRLI T,PNBUF
BLT T,-L.6VRS(FXP)
MOVEI T,177←1 ;MASK FOR LAST BYTE IN AN ASCII WORD
ANDCAM T,-L.6VRS(FXP) ;MAKE SURE LAST BYTE IS NULL
HRRZ A,@(P)
JUMPE A,POP1J ;EXIT IF ALL DONE
HRRZ T,(A) ;IF 3 COMPONENTS REMAIN, THEN VERSION EXISTS
HRRZ T,(T)
SKIPN T
SKIPL -1(P) ;FOR UREAD-STYLE NAMELISTS, READ AT MOST
SKIPA ; TWO COMPONENTS
JRST NML6F4
MOVEM A,(P)
NML6F5:
] ;END OF IFN D20
JSP T,STENT
JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT
HLRZ A,(A)
NML6F2:
IFE D20,[
PUSHJ P,SIXMAK ;CONVERT LAST COMPONENT TO SIXBIT,
10$ TRZ TT,-1 ; TRUNCATING TO 3 CHARS FOR DEC10,
MOVEM TT,(FXP) ; AND CALL IT FILE NAME 2
] ;END OF IFN D20
IFN D20,[
PUSHJ P,PNBFMK ;CONVERT LAST COMPONENT TO ASCIZ,
MOVEI T,-L.6VRS+1(FXP) ; AND CALL IT THE VERSION
HRLI T,PNBUF
BLT T,(FXP)
MOVEI T,177←1 ;MASK FOR LAST BYTE IN AN ASCII WORD
ANDCAM T,(FXP) ;MAKE SURE LAST BYTE IS NULL
] ;END OF IFN D20
NML6F4: HRRZ A,@(P)
JRST POP1J
NML6F3: SETZM (P)
20% JRST NML6F2
20$ JRST NML6F4
;;; CONVERTS A DEVICE/DIRECTORY SPECIFICATION IN A TO "SIXBIT" FORM ON FXP.
;;; PERFORMS DEVICE/DIRECTORY DISAMBIGUATION. SKIPS ON SUCCESS.
NML6DV:
IT$ REPEAT 2, PUSH FXP,[SIXBIT \*\] ;PUSH ROOM FOR DEV/DIR CRUD
10$ PUSH FXP,[SIXBIT \*\]
10$ PUSH FXP,[-1]
20$ PUSHN FXP,L.D6BT ;PUSH ROOM FOR DEV/DIR CRUD
JUMPE A,POPJ1 ;NULL SPEC => DEFAULTS
HRRZ B,(A)
HLRZ A,(A)
PUSH P,B
NML6PP:
IFN D10,[
CAIN A,QLISP ;CHECK FOR "LISP" DEVICE - MAYBE HAS
JRST NML6P1 ; A PPN TRANSLATION TO DSK
JSP T,STENT ;FOR D10, A NON-ATOMIC ITEM MUST BE A PPN
JUMPL TT,NML6D7
NML6P2: ] ;END OF D10
10$ PUSH P,A
20% PUSHJ P,SIXMAK
10$ POP P,A
20$ PUSHJ P,PNBFMK
IFN ITS+D20+CMU,[
SKIPE (P) ;FOR ONLY ONE ITEM, IT COULD BE EITHER
JRST NML6D1 ; DEVICE OR DIRECTORY
PUSHJ P,IDND ;DISAMBIGUATE THIS MESS - SKIP IF DEVICE
CMU% JRST NML6D4 ;JUMP IF A DIRECTORY NAME
CMU$ JRST NML6D8
] ;END OF IFN ITS+D20+CMU
.ELSE,[
PUSHJ P,NML6P3 ;GET PPN PROPERTY
JUMPN A,NML6PP ;HAVE A PPN PROPERTY, SO LOOP
] ;END .ELSE
NML6D1:
20% MOVEM TT,-1(FXP) ;IT'S DEFINITELY A DEVICE NAME
IFN D20,[
MOVEI T,-L.6DEV-L.6DIR+1(FXP)
HRLI T,PNBUF
BLT T,-L.6DIR+1(FXP)
MOVEI T,177←1 ;MASK FOR LAST BYTE IN AN ASCII WORD
ANDCAM T,-L.6DIR(FXP) ;MAKE SURE LAST BYTE IS NULL
] ;END OF IFN D20
SKIPN (P)
JRST POP1J1 ;SUCCESS IF NO DIRECTORY SPEC
HLRZ A,@(P)
IFN D10*<1-CMU>,[
PUSHJ P,NML6P3 ;TRY PPN PROPTERTY
SKIPN A ;USE IT IF IT EXISTS
HLRZ A,@(P) ;ELSE USE THE USER SPECIFIED FROB
] ;END IFN D10*<1-CMU>
HRRZ B,@(P)
MOVEM B,(P)
;HERE IS WHERE IT HITS THE FAN - NO TWO SYSTEMS HAVE THE SAME DIRECTORY SPEC FORMAT!
IFN ITS, PUSHJ P,SIXMAK ;FOR ITS IT IS A PLAIN SIXBIT NAME
IFN D20, PUSHJ P,PNBFMK ;FOR D20 IT IS ASCII
IFN D10,[
NML6D8: SETO TT,
CAIN A,Q. ;* AS A PPN STRING IS TAKEN TO MEAN (* *)
JRST NML6D4
JSP T,STENT
IFN TOPS10+SAIL,[
JUMPGE TT,POP1J ;AN ATOMIC DIRECTORY IS ILLEGAL FOR TOPS10/SAIL
]
IFN CMU,[
JUMPL TT,NML6D7 ;FOR CMU, NON-ATOMIC => TOPS10-STYLE
PUSHJ P,PNBFMK
MOVEI TT,PNBUF ;0,,ADDRESS OF CMU PPN STRING
CMUDEC TT, ;CMUDEC WILL CONVERT A STRING TO A PPN WORD
JRST POP1J ;FAIL IF NOT A VALID CMU PPN
JRST NML6D4
] ;END OF IFN CMU
NML6D7: HLRZ B,(A) ;B GETS PROJECT
HRRZ C,(A)
HLRZ A,(C) ;A GETS PROGRAMMER
HRRZ C,(C)
JUMPN C,POP1J ;FAIL IF THREE ITEMS IN THE PPN SPEC
IFN TOPS10+CMU,[
CAIN B,Q. ;* MEANS AN OMITTED COMPONENT
SKIPA D,[,,-1]
JSP T,FXNV2 ;OTHERWISE EXPECT A FIXNUM
CAIN A,Q.
SKIPA TT,[,,-1]
JSP T,FXNV1
TLNN TT,-1
TLNE D,-1
JRST POP1J ;NUMBERS MUST FIT INTO HALFWORDS
HRLI TT,(D)
] ;END OF IFN TOPS10+CMU
IFN SAIL,[
PUSH P,B
CAIN A,Q. ;* MEANS AN OMITTED COMPONENT
SKIPA TT,[0,,-1]
PUSHJ P,SIXMAK ;OTHERWISE GET SIXBIT
PUSHJ P,SARGHT ;RIGHT JUSTIFY IT
PUSH FXP,TT
POP P,A
CAIN A,Q. ;* MEANS AN OMITTED COMPONENT
SKIPA TT,[0,,-1]
PUSHJ P,SIXMAK ;OTHERWISE GET SIXBIT
PUSHJ P,SARGHT ;RIGHT JUSTIFY IT
POP FXP,D
TLNN TT,-1
TLNE D,-1
JRST POP1J ;NO MORE THAN 3 CHARS APIECE
MOVSS TT
HRRI TT,(D)
] ;END OF IFN SAIL
] ;END OF IFN D10
;NOW WE HAVE THE SNAME/PPN IN TT FOR ITS/D10, OR DIRECTORY IN PNBUF FOR D20
NML6D4:
20% MOVEM TT,(FXP)
IFN D20,[
MOVEI T,-L.6DIR+1(FXP)
HRLI T,PNBUF
BLT T,(FXP)
MOVEI T,177←1 ;MASK FOR LAST BYTE IN AN ASCII WORD
ANDCAM T,(FXP)
] ;END OF IFN D20
SKIPN (P) ;WE WIN IFF THERE ARE NO MORE ITEMS TO PARSE
AOS -1(P)
JRST POP1J
IFN D10,[
NML6P1: PUSH P,A ;CHECK TO SEE IF "LISP" DEVICE HAS
PUSHJ P,NML6P3 ; A PPN TRANSLATION
POP P,B
JUMPN A,.+3
EXCH A,B
JRST NML6P2 ;NO, SO GO ORDINARY ROUTE
MOVSI TT,(SIXBIT \DSK\) ;BUT IF SO, THEN FORCE DEVICE TO BE "DSK"
MOVEM TT,-1(FXP) ; AND GET PPN FROM PROPERTY LIST.
JRST NML6D8
NML6P3: MOVEI B,QPPN ;CHECK TO SEE IF SYMBOL HAS PPN PROPERTY
PUSH FXP,TT ; AND USE `(DSK ,(proj prog)) IF FOUND
PUSHJ P,GET
JRST RSTX1
] ;END OF IFN D10
IFN SAIL,[
;RIGHT JUSTIFY SIXBIT WORD IN TT
SARGHT: SKIPE TT ;IF NOTHING THERE WE DON'T WANT TO LOOP
TRNE TT,77 ;ANYTHING IN HIGH SIXBIT BYTE?
POPJ P, ;YUP, IT IS THEREFORE LEFT-JUSTIFIED
LSH TT,-6 ;ELSE GET RID OF THE LEADING BLANK
JRST SARGHT ;AND PROCEED WITH TEST
] ;END IFN SAIL
IFN ITS+CMU+D20,[
;;; INSUFFERABLE DEVICE NAME DISTINGUISHER - SKIP.RETURN IF ARG IS DEVICE
;;; A NAME IS IN TT IN SIXBIT (ITS/CMU) OR IN PNBUF IN ASCII (D20).
;;; TRIES TO DECIDE WHETHER A NAME IS A DEVICE NAME OR A DIRECTORY NAME.
;;; FOR ITS, IT IS A DEVICE NAME IFF, AFTER STRIPPING OFF TRAILING DIGITS,
;;; IT IS IN THE TABLE OF KNOWN DEVICE NAMES.
;;; FOR CMU, WE USE THE DEVCHR UUO TO TEST EXISTENCE.
;;; FOR D20, WE USE THE STDEV JSYS TO TEST EXISTENCE.
;;; SKIPS IF A DEVICE NAME. MUST PRESERVE A AND TT.
IFN CMU,[
IDND: MOVE F,TT
CAME F,[SIXBIT \LISP\]
DEVCHR F, ;FOR CMU, GET CHARACTERISTICS OF DEVICE
JUMPE F,CPOPJ ;ZERO WORD MEANS DEVICE DOESN'T EXIST
JRST POPJ1
] ;END OF IFN CMU
IFN D20,[
IDND: PUSH P,A
LOCKI ;LOCK OUT INTERRUPTS AROUND THE JSYS
HRROI A,PNBUF
STDEV ;CONVERT DEVICE STRING TO DEVICE DESIGNATOR
CAIA ;ERROR - NO SUCH DEVICE
AOS -1(P) ;IF DEVICE, SKIP RETURN FOR STDEV AND US TOO
POP P,A
UNLKPOPJ
] ;END OF IFN D20
IFN ITS,[
;;; BEWARE! THIS TABLE IS SORTED ALPHABETICALLY, AND THAT IS REQUIRED BY
;;; THE SUPER-HAIRY BINARY SORT HACK ABOVE. TABLE MUST BE AN EXACT POWER OF
;;; TWO IN LENGTH SO WE CAN USE SUPER-WINNING BINARY SEARCH METHOD.
IDNTB:
IRP X,,[AI,AIAR,AIDIR,AR,ARC,BOJ,CLA,CLI,CLO,CLU,COM,COR
DIR,DK,DM,DMAR,DMDIR,DSK,ERR,JOB,LPT,MC,MCAR,MCDIR,ML,MLAR,MLDIR
MT,NUL,OJB,P,PK,PTP,PTR,S,SPY,ST,STY,SYS,T,TPL,TTY,TY,USR,UT
]
SIXBIT \X\
TERMIN
LIDNTB==:.-IDNTB
HAOLNG LOG2IDNTB,<.-IDNTB-1>
REPEAT <1←LOG2IDNTB>-LIDNTB,[ -1
] ;END OF REPEAT <1←LOG2IDNTB>-LIDNTB,
IDND: MOVE F,TT ;SAVE TT IN F
MOVNI R,6
IDND1: SETZ TT-1, ;WE WILL STRIP DIGITS AND NULLS FROM END
ROTC TT-1,-6 ; BY ROTATING THEM INTO THE PREVIOUS AC
ROT TT-1,6
JUMPE TT-1,IDND2
CAIL TT-1,'0
CAILE TT-1,'9
JRST IDND3 ;EXIT IF NEITHER DIGIT NOR NULL
IDND2: AOJL R,IDND1
POPJ P, ;SHIFTED OUT ALL CHARACTERS?
IDND3: ROT TT-1,-6
XCT IDNDLS+6(R) ;SHIFT BACK
SETZB R,T
REPEAT LOG2IDNTB,[
CAML TT,IDNTB+<1←<LOG2IDNTB-.RPCNT-1>>(R)
ADDI R,1←<LOG2IDNTB-.RPCNT-1>
] ;END OF REPEAT LOG2IDNTB
CAMN TT,IDNTB(R) ;IF NOT IN TABLE, THEN MUST BE A DIRECTORY
AOS (P) ;IT'S A DEVICE - SO DO SKIP RETURN
MOVE TT,F ;RESTORE TT
POPJ P,
IDNDLS:
REPEAT 6,[ROTC TT-1,<.RPCNT+1>*6
] ;END OF REPEAT 6,
POPJ P, ;STANDARD EXIT IF TOO MANY SHIFTS
] ;END OF IFN ITS
] ;END OF IFN ITS+CMU+D20
;NAMELIST 6BTNML 6BTNL3 6BTNL4
SUBTTL CONVERSION: SIXBIT => NAMELIST
;;; THIS ROUTINE TAKES "SIXBIT" FORMAT ON FXP AND,
;;; POPPING THEM, RETURNS THE EQUIVALENT CANONICAL NAMELIST.
;;; OMITTED COMPONENTS BECOME *'S.
;;; THE NAMELIST FUNCTION MERELY CONVERTS ARG TO SIXBIT,
;;; THEN BACK TO (CANONICAL) NAMELIST FORM.
NAMELIST:
PUSHJ P,FIL6BT ;SUBR 1
6BTNML: JSP T,QIOSAV ;MUST ALSO PRESERVE F
PUSHN P,1
;FOR D20, POP THE VERSION (TENEX)/GENERATION (TOPS20) AND CONS IT UP
IFN D20,[
REPEAT L.6VRS, POP FXP,PNBUF+L.6VRS-.RPCNT-1
PUSHJ P,6BTNL3
] ;END OF IFN D20
;POP THE FILE NAME 2 (ITS)/EXTENSION (D10, TENEX)/TYPE (TOPS20) AND CONS UP
IFN ITS+D10, POP FXP,TT
IFN D10, TRZ TT,-1 ;D10 EXTENSION IS AT MOST 3 CHARACTERS
IFN D20,[
MOVEI T,PNBUF
HRLI T,-L.6EXT+1(FXP)
BLT T,PNBUF+L.6EXT-1
POPI FXP,L.6EXT
] ;END OF IFN D20
PUSHJ P,6BTNL3
;POP THE FILE NAME 1 (ITS)/FILE NAME (D10, D20) AND CONS UP
IFN ITS+D10, POP FXP,TT
IFN D20,[
MOVEI T,PNBUF
HRLI T,-L.6FNM+1(FXP)
BLT T,PNBUF+L.6FNM-1
POPI FXP,L.6FNM
] ;END OF IFN D20
PUSHJ P,6BTNL3
;NOW FOR THE DEVICE/DIRECTORY PORTION
PUSHN P,1
;FIRST THE DIRECTORY (WHAT A MESS!)
IFN ITS,[
POP FXP,TT
PUSHJ P,6BTNL3
] ;END OF IFN ITS
IFN D10,[
POP FXP,TT
PUSHJ P,PPNATM
PUSHJ P,6BTNL4
] ;END OF IFN D10
IFN D20,[
MOVEI T,PNBUF
HRLI T,-L.6DIR+1(FXP)
BLT T,PNBUF+L.6DIR-1
POPI FXP,L.6DIR
PUSHJ P,6BTNL3
] ;END OF IFN D20
;FINALLY, THE DEVICE NAME
20% POP FXP,TT
IFN D20,[
MOVEI T,PNBUF
HRLI T,-L.6DEV+1(FXP)
BLT T,PNBUF+L.6DEV-1
POPI FXP,L.6DEV
] ;END OF IFN D20
PUSHJ P,6BTNL3
POP P,A
POP P,B
JRST CONS
SA$ 6BTNL9: SKIPA A,[Q.]
6BTNL3:
20% PUSHJ P,SIXATM
20$ PUSHJ P,PNBFAT
6BTNL4: MOVE B,-1(P)
PUSHJ P,CONS
MOVEM A,-1(P)
POPJ P,
;SHORTNAMESTRING NAMESTRING 6BTNMS X6BTNSL 6BTNSL 6BTNS 6BNS0A 6BTNS0 6BNS4A 6BTNS4 6BTNS5 6BTNS8 6BTNS1 6BTNS2 6BTNS3 6BTNS2 6BTNS3 6BTNS6 6BNS6A 6BNS7A 6BTNS7 6BNS7B
SUBTTL CONVERSION: SIXBIT => NAMESTRING
;;; THIS ROUTINE TAKES A "SIXBIT" FORMAT FILE SPEC ON FXP
;;; AND GENERATES AN UNINTERNED ATOMIC SYMBOL WHOSE
;;; PRINT NAME IS THE EXTERNAL FORM OF FILE SPECIFICATION.
;;; OMITTED NAMES ARE EITHER NOT INCLUDED IN THE NAMESTRING
;;; OR REPRESENTED AS "*".
;;; THE NAMESTRING AND SHORTNAMESTRING MERELY CONVERT THEIR
;;; ARGUMENTS TO SIXBIT AND THEN INTO NAMESTRING FORM.
SHORTNAMESTRING: ;SUBR 1
TDZA TT,TT
NAMESTRING: ;SUBR 1
SETO TT,
HRLM TT,(P)
PUSHJ P,FIL6BT
6BTNMS: MOVEI TT,PNGNK2
HLL TT,(P) ;TO MAKE A NAMESTRING, GET IT INTO PNBUF
PUSH P,TT
JRST 6BTNS ; AND THEN PNGNK2 WILL MAKE A SYMBOL
IFN D20,[
X6BTNSL: MOVEI T,L.F6BT ;MAKES STRING IN PNBUF, BUT NO POPPING
PUSH FXP,-L.F6BT+1(FXP) ; THE FILE NAMES (WE COPY THEM FIRST)
SOJG T,.-1
] ;END OF IFN D20
6BTNSL: SETO TT, ;IF RETURN ADDRESS SLOT ON THE PDL IS
HRLM TT,(P) ; POSITIVE, THEN DO "SHORTNAMESTRING"
6BTNS: JSP T,QIOSAV ;CONVERT "SIXBIT" TO A STRING IN PNBUF
; (BETTER BE BIG ENOUGH!)
SETOM LPNF ;SET FLAG SAYING IT FITS IN PNBUF
20% MOVEI R,↑Q ;R CONTAINS THE CHARACTER FOR QUOTING
20$ MOVEI R,↑V ; PECULIAR CHARACTERS IN COMPONENTS
MOVE C,PNBP
SKIPL -LQIOSV(P) ;SKIP UNLESS SHORTNAMESTRING
JRST 6BTNS0
;DEVICE NAME (NOT FOR SHORTNAMESTRING, THOUGH)
IFN ITS+D10,[
SKIPE TT,-3(FXP)
CAMN TT,[SIXBIT \*\]
JRST 6BNS0A ;JUMP IF DEVICE NAME OMITTED
] ;END OF IFN ITS+D10
IFN D20,[
SKIPN -L.6DEV-L.6DIR-L.6FNM-L.6EXT-L.6VRS+1(FXP)
JRST 6BNS0A ;JUMP IF DEVICE NAME OMITTED
MOVEI TT,-L.6DEV-L.6DIR-L.6FNM-L.6EXT-L.6VRS+1(FXP)
] ;END OF IFN D20
PUSHJ P,6BTNS1
MOVEI TT,": ;9 OUT OF 10 OPERATING SYSTEMS AGREE:
IDPB TT,C ; ":" MEANS A DEVICE NAME.
6BNS0A:
;FOR ITS AND D20, DIRECTORY NAME COMES NEXT
IFN ITS,[
SKIPE TT,-2(FXP)
CAMN TT,[SIXBIT \*\]
JRST 6BTNS0 ;DIRECTORY NAME OMITTED
PUSHJ P,6BTNS1
MOVEI TT,"; ;";" MEANS DIRECTORY NAME TO ITS
IDPB TT,C
] ;END OF IFN ITS
IFN D20,[
SKIPN -L.6DIR-L.6FNM-L.6EXT-L.6VRS+1(FXP)
JRST 6BTNS0 ;DIRECTORY NAME OMITTED
MOVEI TT,"< ;D20 DIRECTORY NAME APPEARS IN <>
IDPB TT,C
MOVEI TT,-L.6DIR-L.6FNM-L.6EXT-L.6VRS+1(FXP)
PUSHJ P,6BTNS1
MOVEI TT,">
IDPB TT,C
] ;END OF IFN D20
6BTNS0:
;NOW WE ATTACK THE FILE NAME
20% MOVE TT,-1(FXP)
20$ MOVEI TT,-L.6FNM-L.6EXT-L.6VRS+1(FXP)
PUSHJ P,6BTNS1
;NOW THE FILE NAME 2/EXTENSION/TYPE
IFN ITS, MOVEI TT,40
IFN D10+D20, MOVEI TT,".
10$ SKIPE (FXP)
IDPB TT,C
IT$ MOVE TT,(FXP)
10$ HLLZ TT,(FXP)
20$ MOVEI TT,-L.6EXT-L.6VRS+1(FXP)
IT% SKIPE TT
PUSHJ P,6BTNS1
IFN D20,[
;FOR D20, THE VERSION/GENERATION COMES LAST
WARN [HOW TO DISTINGUISH NULL VERSION FROM *?]
SKIPN -L.6VRS+1(FXP)
JRST 6BTNS8
MOVEI TT,";
SKIPN TENEXP
MOVEI TT,".
IDPB TT,C
MOVEI TT,-L.6VRS+1(FXP)
PUSHJ P,6BTNS1
] ;END OF IFN D20
IFN D10,[
;FOR D10, THE DIRECTORY COMES LAST
MOVE TT,-2(FXP)
CAME T,XC-1 ;FORGET IT IF BOTH HALVES OMITTED
SKIPL -6(P) ;NO DIRECTORY FOR SHORTNAMESTRING
JRST 6BTNS8
MOVEI TT,133 ;A LEFT BRACKET
IDPB TT,C
IFN CMU,[
HLRZ T,-2(FXP)
CAIG T,10 ;ONLY PROJECTS ABOVE 10 ARE IN CMU FORMAT
JRST 6BTNS4
PUSHN FXP,2 ;THERE IS A BUG IN DECCMU, BUT PUSHING ZERO WORDS
MOVEI T,-1(FXP) ; GETS US AROUND IT
HRLI T,-4(FXP)
DECCMU T,
JRST 6BTNS4 ;ON FAILURE, JUST USE DEC FORMAT
MOVEI T,-1(FXP)
TLOA T,440700
6BNS4A: IDPB TT,C ;COPY CHARACTERS INTO PNBUF
ILDB TT,T
JUMPN TT,6BNS4A
POPI FXP,2
JRST 6BTNS5
6BTNS4:
] ;END OF IFN CMU
HLLZ TT,-2(FXP)
PUSHJ P,6BTNS6 ;OUTPUT PROJECT
MOVEI TT,", ;COMMA SEPARATES HALVES
IDPB TT,C
HRLZ TT,-2(FXP)
PUSHJ P,6BTNS6 ;OUTPUT PROGRAMMER
6BTNS5: MOVEI TT,135 ;A RIGHT BRACKET
IDPB TT,C
] ;END OF IFN D10
6BTNS8: PUSHJ FXP,RDAEND ;FINISH OFF THE LAST WORD OF THE STRING
SETZM 1(C)
POPI FXP,L.F6BT ;POP CRUD OFF STACK
MOVEM C,-LQIOSV+2(P) ;CROCK DUE TO SAVED AC C
POPJ P,
;;; COME HERE TO ADD A COMPONENT TO THE GROWING NAMESTRING IN PNBUF.
;;; FOR ITS AND D10, THE SIXBIT IS IN TT, AND MUST BE CONVERTED.
;;; FOR DEC20, TT HAS A POINTER TO THE ASCIZ STRING TO ADD.
6BTNS1:
IFN ITS+D10,[
SKIPN TT ;A ZERO WORD GETS OUTPUT AS "*"
MOVSI TT,(SIXBIT \*\)
6BTNS2: SETZ T,
LSHC T,6
JUMPE T,6BTNS3
10$ CAIE T,133-40 ;FOR DEC-10, BRACKETS MUST
10$ CAIN T,135-40 ; BE QUOTED
10$ JRST 6BTNS3
CAIE T,':
10% CAIN T,';
10$ CAIN T,'.
6BTNS3: IDPB R,C ;↑Q TO QUOTE FUNNY CHARS
ADDI T,40
IDPB T,C
JUMPN TT,6BTNS2
POPJ P,
] ;END OF IFN ITS+D10
IFN D20,[
SETZ D,
HRLI TT,440700
6BTNS2: ILDB T,TT
JUMPE T,CPOPJ
TRZE D,1 ;D IS THE PRECEDING-CHAR-WAS-↑V FLAG
JRST 6BTNS3
IRPC X,,[:;<>=←*@ ,] ;EVEN NUMBER OF GOODIES!
IFE .IRPCNT&1, CAIE T,"X
.ELSE,[
CAIN T,"X
IDPB R,C ;QUOTE FUNNY CHARACTER
] ;END OF .ELSE
TERMIN
IFN TOPS20,[ ;TOPS20 REQUIRES ADDITONAL CHARACTERS TO BE QUOTED
IRPC X,,[()[]{}/!"#%&'\|`↑}]
IFE .IRPCNT&1, CAIE T,"X
.ELSE,[
CAIN T,"X
IDPB R,C ;QUOTE FUNNY CHARACTER
] ;END OF .ELSE
TERMIN
] ;END OF IFN TOPS20
CAIN T,(R)
TRO D,1
6BTNS3: IDPB T,C
JRST 6BTNS2
] ;END OF IFN D20
IFN D10,[
;;; CONVERT ONE HALF OF A PPN, PUTTING ASCII CHARS IN PNBUF
6BTNS6: JUMPE TT,6BNS6A
CAME TT,[-1,,]
AOJA TT,6BTNS7 ;ADDING ONE PRODUCES A FLAG BIT
6BNS6A: MOVEI TT,"* ;AN OMITTED HALF IS OUTPUT AS "*"
IDPB TT,C
POPJ P,
6BNS7A: LSH TT,3+3*SAIL ;ZERO-SUPPRESS OCTAL (TOPS10/CMU), LEFT-JUSTIFY CHARS (SAIL)
6BTNS7: TLNN TT,770000←<3*<1-SAIL>>
JRST 6BNS7A ;NOTE THAT THE FLAG BIT GETS SHIFTED TOO
6BNS7B: SETZ T,
LSHC T,3+3*SAIL
SA% ADDI T,"0
SA$ ADDI T,40
IDPB T,C
TRNE TT,-1 ;WE'RE DONE WHEN THE FLAG BIT LEAVES THE RIGHT HALF
JRST 6BNS7B
POPJ P,
] ;END OF IFN D10
;NMS NMS.CQ NMS.CA NMS.DV NMS.FN NMS.DT NMS.XT NMS.LB NMS.CM NMS.RB NMS.ND NMS.ST NMS6BF NMS6B0 NMS6BT NMS6B1 NMS6B8 NMS6B6 NMS6B5 NMS6B7 NMS6B9 NMS6B4 NMS6BQ NMS6BL NMS6DV NMS6SN NMS6PD NMS6LB NMS6L1 NMS6CM NMS6RB NMS6R2 NMS6R1 NMS6ST NMS6PP
SUBTTL CONVERSION: NAMESTRING => SIXBIT
;;; THIS ONE IS PRETTY HAIRY. IT CONVERTS AN ATOMIC
;;; SYMBOL IN A, REPRESENTING A FILE SPECIFICATION,
;;; INTO "SIXBIT" FORMAT ON FXP. THIS INVOLVES
;;; PARSING A FILE NAME IN STANDARD ASCII STRING FORMAT
;;; AS DEFINED BY THE HOST OPERATING SYSTEM.
;;; FOR D20, THE OPERATING SYSTEM GIVES US SOME HELP.
;;; FOR ITS AND D10, WE ARE ON OUR OWN.
IFN ITS+D10,[
;;; THE GENERAL STRATEGY HERE IS TO CALL PRINTA TO EXPLODEC THE NAMESTRING.
;;; A PARSING COROUTINE TAKES THE SUCCESSIVE CHARACTERS AND INTERPRETS THEM.
;;; EACH COMPONENT IS ASSEMBLED IN SIXBIT FORM, AND WHEN IT IS TERMINATED
;;; BY A BREAK CHARACTER, IT IS PUT INTO ONE OF FOUR SLOTS RESERVED ON FXP.
;;; FOR CMU, WE ALSO ASSEMBLE THE CHARACTERS INTO PNBUF IN ASCII FORM,
;;; SO THAT WE CAN USE THE CMUDEC UUO TO CONVERT A CMU-STYLE PPN.
;;; AR1 HOLDS THE BYTE POINTER FOR ACCUMULATING A NAME.
;;; AR2A HOLDS MANY FLAGS DESCRIBING THE STATE OF THE PARSE:
NMS==:1,,525252 ;FOR BIT-TYPEOUT MODE
NMS.CQ==:1 ;CONTROL-Q SEEN
NMS.CA==:2 ;CONTROL-A SEEN
IFN D10,[
NMS.DV==:10 ;DEVICE SEEN (AND TERMINATING :)
NMS.FN==:20 ;FILE NAME SEEN
NMS.DT==:40 ;. SEEN
NMS.XT==:100 ;EXTENSION SEEN
NMS.LB==:200 ;LEFT BRACKET SEEN
NMS.CM==:400 ;COMMA SEEN
NMS.RB==:1000 ;RIGHT BRACKET SEEN
NMS.ND==:10000 ;NON-OCTAL-DIGIT SEEN
NMS.ST==:20000 ;* SEEN
] ;END OF IFN D10
;;; CONTROL-A IS THE SAIL CONVENTION FOR QUOTING MANY CHARACTERS, BUT WE
;;; ADOPT IT FOR ALL ITS AND D10 SYSTEMS.
CMU% LNMSXBLK==L.F6BT+1
CMU$ LNMSXBLK==L.F6BT+1+1
;;; CMU SYSTEM KEEPS AN EXTRO BYTE-PTR ON FXP
NMS6BF: POP P,A
POPI FXP,LNMSXBLK
NMS6B0: WTA [BAD NAMESTRING!]
NMS6BT: MOVEI TT,(A) ;DON'T ALLOW FIXNUMS AS NAMESTRINGS
LSH TT,-SEGLOG
MOVSI R,FX
TDNE R,ST(TT) ;A FIXNUM?
JRST NMS6B0 ;YES, ILLEGAL AS A NAMESTRING
PUSH P,A
PUSHN FXP,L.F6BT+1 ;FOUR WORDS FOR FINISHED NAMES, ONE FOR ACCUMULATION
MOVEI AR1,(FXP) ;AR1 HOLDS THE BYTE POINTER FOR ACCUMULATING A NAME
HRLI AR1,440600
CMU$ PUSH FXP,PNBP ;FOR CMU, WE NEED THIS TO PARSE THE PPN
CMU$ SETZM PNBUF+LPNBUF-1
SETZ AR2A, ;ALL FLAGS INITIALLY OFF
HRROI R,NMS6B1 .SEE PR.PRC
PUSHJ P,PRINTA ;PRINTA WILL CALL NMS6B1 WITH SUCCESSIVE CHARS IN A
TLNE AR2A,NMS.CA+NMS.CQ
JRST NMS6BF ;ILLEGAL FOR A QUOTE TO BE HANGING
MOVEI A,40
PUSHJ P,(R) ;FORCE A SPACE THROUGH TO TERMINATE LAST COMPONENT
IFN D10,[
TLNE AR2A,NMS.LB
TLNE AR2A,NMS.RB
CAIA
JRST NMS6BF ;LOSE IF LEFT BRACKET SEEN BUT NO RIGHT BRACKET
] ;END OF IFN D10
JUMPE AR1,NMS6BF ;AR1 IS ZEROED IF THE PARSING CORUTINE DETECTS AN ERROR
POP P,A
POPI FXP,LNMSXBLK-L.F6BT
MOVSI T,(SIXBIT \*\) ;CHANGE ANY ZERO COMPONENTS TO "*"
SKIPN -3(FXP)
MOVEM T,-3(FXP) ;DEVICE NAME
IT$ SKIPN -2(FXP)
IT$ MOVEM T,-2(FXP) ;SNAME
IFN D10,[
MOVE TT,-2(FXP) ;TREAT HALVES OF PPN SEPARATELY
TLNN TT,-1 ;A ZERO HALF BECOMES -1
TLO TT,-1
TRNN TT,-1
TRO TT,-1
MOVEM TT,-2(FXP)
] ;END OF IFN D10
SKIPN -1(FXP)
MOVEM T,-1(FXP) ;FILE NAME 1
SA$ MOVSI T,(SIXBIT \←←←\)
SKIPN (FXP)
MOVEM T,(FXP) ;FILE NAME 2/EXTENSION
POPJ P,
;;; THIS IS THE NAMESTRING PARSING COROUTINE
NMS6B1: JUMPE AR1,CPOPJ ;ERROR HAS BEEN DETECTED, FORGET THIS CHARACTER
CAIN A,↑A
JRST NMS6BQ
CAIN A,↑Q
TLCE AR2A,NMS.CQ ;FOR A CONTROL-Q, SET THE CONTROL-Q BIT
CAIA ;IF IT WAS ALREADY SET, IT'S A QUOTED ↑Q
POPJ P, ;OTHERWISE EXIT
CAIN A,40 ;SPACE?
TLZN AR2A,NMS.CQ ;YES, QUOTED?
SKIPA ;NO TO EITHER TEST
JRST NMS6B9 ;YES TO BOTH, IS QUOTED SPACE
CAILE A,40 ;SKIP OF CONTROL CHARACTER OR SPACE
JRST NMS6B7
;WE HAVE ENCOUNTERED A BREAK CHARACTER - DECIDE WHAT TO DO WITH COMPONENT
NMS6B8: SKIPN D,(AR1)
POPJ P, ;NO CHARACTERS ASSEMBLED YET
IT$ SKIPN -2(AR1) ;IF WE HAVE A FILE NAME 1, THIS MUST BE FN2
10$ TLNN AR2A,NMS.DT ;WE HAVE SEEN A DOT, THIS MUST BE THE EXTENSION
JRST NMS6B5 ;OTHERWISE THIS IS FILE NAME 1
IT$ SKIPE -1(AR1) ;LOSE IF WE ALREADY HAVE A FILE NAME 2
10$ TLNE AR2A,NMS.XT+NMS.LB+NMS.CM+NMS.RB
JRST NMS6BL ;LOSE IF EXTENSION AFTER BRACKETS OR OTHER ONE
IT$ MOVEM D,-1(AR1)
10$ HLLZM D,-1(AR1)
10$ TLO AR2A,NMS.XT ;SET FLAG: WE'VE SEEN THE EXTENSION
;COME HERE TO RESTORE THE BYTE POINTER FOR THE NEXT COMPONENT
NMS6B6: JUMPE AR1,CPOPJ ;IF AN ERROR HAS BEEN DETECTED, EXIT
HRLI AR1,440600
CMU$ MOVE D,PNBP ;FOR CMU, RESET THE PNBUF BYTE POINTER ALSO
CMU$ MOVEM D,1(AR1)
10$ TLZ AR2A,NMS.ND+NMS.ST ;RESET NON-OCTAL-DIGIT AND STAR SEEN FLAGS
SETZM (AR1) ;CLEAR ACCUMULATION WORD
POPJ P,
;COME HERE FOR FILE NAME 1
NMS6B5:
10$ TLNE AR2A,NMS.FN+NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB
10$ JRST NMS6BL ;LOSE IF TOO LATE FOR A FILE NAME
MOVEM D,-2(AR1) ;SAVE FILE NAME 1
JRST NMS6B6
;HERE WITH A NON-CONTROL NON-SPACE CHARACTER
NMS6B7: TLZN AR2A,NMS.CQ
TLNE AR1,NMS.CA
JRST NMS6B9 ;IF CHARACTER QUOTED (FOR ↑Q, FLAG IS RESET)
CAIN A,":
JRST NMS6DV ;: SIGNALS A DEVICE NAME
IT$ CAIN A,";
IT$ JRST NMS6SN ;; MEANS AN SNAME
IFN D10,[
CAIN A,".
JRST NMS6PD ;PERIOD MEANS TERMINATION OF FILE NAME
CAIN A,133
JRST NMS6LB ;LEFT BRACKET
CAIN A,",
JRST NMS6CM ;COMMA
CAIN A,135
JRST NMS6RB ;RIGHT BRACKET
CAIN A,"*
JRST NMS6ST ;STAR
] ;END OF IFN D10
;HERE TO DUMP A CHARACTER INTO THE ACCUMULATING COMPONENT
NMS6B9:
IFN CMU,[
SKIPE PNBUF+LPNBUF-1
TDZA AR1,AR1 ;ASSUME A COMPONENT THAT FILLS PNBUF IS A LOSER
IDPB A,1(AR1) ;STICK ASCII CHARACTER IN PNBUF
] ;END OF IFN CMU
IFN D10,[
CAIL A,"0
CAILE A,"7
TLO AR2A,NMS.ND ;SET FLAG IF NON-OCTAL-DIGIT
NMS6B4:
] ;END OF IFN D10
CAIGE A,140 ;CONVERT LOWER CASE TO UPPER,
SUBI A,40 ; AND ASCII TO SIXBIT
TLNE AR1,770000
IDPB A,AR1 ;DUMP CHARACTER INTO ACCUMULATING NAME
POPJ P,
NMS6BQ: TLCA AR2A,NMS.CA ;COMPLEMENT CONTROL-A FLAG
NMS6BL: SETZ AR1, ;ZEROING AR1 INDICATES A PARSE ERROR
POPJ P,
NMS6DV: SKIPE D,(AR1) ;ERROR IF : SEEN WITH NO PRECEDING COMPONENT
10$ ;ERROR AFTER OTHER CRUD
10$ TLNE AR2A,NMS.DV+NMS.FN+NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB
10% SKIPE -4(AR1) ;ERROR IF DEVICE NAME ALREADY SEEN
JRST NMS6BL
MOVEM D,-4(AR1)
10$ TLO AR2A,NMS.DV
JRST NMS6B6 ;RESET BYTE POINTER
IFN ITS,[
NMS6SN: SKIPE D,(AR1) ;ERROR IF ; SEEN WITHOUT PRECEDING COMPONENT
SKIPE -3(AR1) ;ERROR IF WE ALREADY HAVE AN SNAME
JRST NMS6BL
MOVEM D,-3(AR1)
JRST NMS6B6 ;RESET BYTE POINTER
] ;END OF IFN ITS
IFN D10,[
NMS6PD: TLNE AR2A,NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB
JRST NMS6BL
PUSHJ P,NMS6B8 ;DOT SEEN - SEE IF IT TERMINATED THE FILE NAME
TLO AR2A,NMS.DT ;SET PERIOD (DOT) FLAG
POPJ P,
NMS6LB: TLNE AR2A,NMS.LB+NMS.CM+NMS.RB
JRST NMS6BL ;LEFT BRACKET ERROR IF ALREADY A BRACKET
PUSHJ P,NMS6B8 ;DID WE TERMINATE THE FILE NAME OR EXTENSION?
TLO AR2A,NMS.LB ;SET LEFT BRACKET FLAG
NMS6L1:
SA% HRLI AR1,440300
SA$ HRLI AR1,440600
POPJ P,
NMS6CM: LDB D,[360600,,AR1]
CAIE D,44 ;ERROR IF NO CHARACTERS AFTER LEFT BRACKET
TLNN AR2A,NMS.LB ;ERROR IF NO LEFT BRACKET!
JRST NMS6BL
SA% TLNE AR2A,NMS.ND+NMS.CM+NMS.RB
SA$ TLNE AR2A,NMS.CM+NMS.RB
JRST NMS6BL ;ERROR IF NON-OCTAL-DIG, COMMA, OR RGT BRACKET
PUSHJ P,NMS6PP ;HACK HALF A PPN
JUMPE AR1,CPOPJ
HRLM D,-3(AR1)
TLO AR2A,NMS.CM ;SET COMMA FLAG
SETZM (AR1) ;CLEAR COLLECTING WORD
JRST NMS6L1 ;RESET BYTE POINTER
NMS6RB:
LDB D,[360600,,AR1]
CMU% TLNE AR2A,NMS.CM ;MUST HAVE COMMA BEFORE RIGHT BRACKET
CAIN D,44 ;ERROR IF NO CHARS SINCE COMMA/LEFT BRACKET
JRST NMS6BL
TLNE AR2A,NMS.LB ;ERROR IF NO LEFT BRACKET
TLNE AR2A,NMS.RB ;ERROR IF RIGHT BRACKET ALREADY SEEN
JRST NMS6BL
CMU$ TLNN AR2A,NMS.CM ;FOR CMU, NO COMMA MEANS A CMU-STYLE PPN
CMU$ JRST NMS6R1
PUSHJ P,NMS6PP ;FIGURE OUT HALF A PPN
JUMPE AR1,CPOPJ
HRRM D,-3(AR1)
NMS6R2: TLO AR2A,NMS.RB ;SET RIGHT BRACKET FLAG
JRST NMS6B6 ;RESET THE WORLD
IFN CMU,[
NMS6R1: MOVEI D,PNBUF
CMUDEC D, ;CONVERT CMU-STYLE PPN TO A WORD
JRST NMS6BL ;LOSE LOSE
MOVEM D,-3(AR1) ;WIN - SAVE IT AWAY
JRST NMS6R2
] ;END OF IFN CMU
NMS6ST: TLOE AR2A,NMS.ST ;SET STAR FLAG, SKIP IF NOT ALREADY SET
TLO AR2A,NMS.ND ;TWO STARS = A NON-DIGIT FOR PPN PURPOSES
JRST NMS6B4
NMS6PP:
SA% TLNE AR2A,NMS.ND
SA% SETZ AR1, ;NON-DIGIT IN PPN IS AN ERROR
HRRZI D,-1
TLNE AR2A,NMS.ST ;STAR => 777777
POPJ P,
LDB TT,[360600,,AR1]
CAIGE TT,22
SETZ AR1, ;MORE THAN SIX DIGITS LOSES
MOVNS TT
MOVE D,(AR1)
LSH D,(TT) ;RIGHT-JUSTIFY THE DIGITS
POPJ P,
] ;END OF IFN D10
] ;END OF IFN ITS+D10
;NMS6BB NMS6BA NMS6B0 NMS6BT JFN6BT JFN6BX JFN6BZ JFN6BY JFN6ER LFGB20 LFGB10
IFN D20,[
;;; THE STRATEGY HERE IS TO USE GTJFN TO PARSE THE STRING,
;;; THEN GET THE VARIOUS COMPONENTS BACK SINGLY WITH JFNS.
NMS6BB: MOVE A,AR1
NMS6BA: UNLOCKI
NMS6B0: %WTA (T)
NMS6BT: MOVEI T,[SIXBIT \FIXNUM ILLEGAL AS NAMESTRING\]
LOCKI ;LOCK OUT INTERRUPTS (BECAUSE OF JSYS'S)
MOVEI TT,(A) ;DON'T ALLOW FIXNUMS AS NAMESTRINGS
LSH TT,-SEGLOG
MOVSI R,FX
TDNE R,ST(TT) ;A FIXNUM?
JRST NMS6BA ;YES, ILLEGAL AS A NAMESTRING
PUSHJ P,PNBFMK ;STRING OUT CHARACTERS INTO PNBUF
MOVEI T,[SIXBIT \NAMESTRING TOO LONG!\]
JUMPE AR2A,NMS6BA ;LOSE IF DIDN'T FIT IN PNBUF
SETZ B,
IDPB B,AR1 ;TERMINATE STRING WITH A NULL (ZERO) BYTE
MOVE AR1,A ;SAVE ORIGINAL ARG IN CASE OF ERROR
MOVEI T,[SIXBIT \LONG GTJFN FAILED IN NAMESTRING!\]
MOVEI 1,LFGB20
SKIPN TENEXP
MOVEI 1,LFGB10
MOVE 2,PNBP
GTJFN ;GET A JFN FOR PARSED NAMESTRING
IOJRST 0,NMS6BB ; PRESUMABLY, THE COMPONENTS CANT BE "TOO LONG"
;R=0 => NMS6BT
TDZA R,R ;CONVERT JFN IN 1 TO "SIXBIT" ON FXP
JFN6BT: MOVEI R,1 ; SKIP ON FAILURE
POP FXP,F ;POP LOCKI WORD (COME IN LOCKED, EXIT UNLOCKED)
MOVE D,FXP .SEE TRUENAME
MOVE 2,1 ;"INDEXABLE FILE HANDLE" RETURNED BY GTJFN
MOVSI 3,(JS%DEV&<.JSAOF*111111111111>) ;.JSAOF IS FOR A 3-BIT FIELD
.SEE JS%DEV JS%DIR JS%NAM JS%TYP JS%GEN
IRP LEN,,[L.6DEV,L.6DIR,L.6FNM,L.6EXT,L.6VRS]FLD,,[DEVICE,DIRECTORY,NAME,TYPE,GENERATION]
SETZM PNBUF
MOVE T,[PNBUF,,PNBUF+1]
BLT T,PNBUF+LEN-1 ;CLEAR OUT PNBUF
MOVE 1,PNBP
JFNS ;GET ASCIZ STRING FOR NEXT COMPONENT IN PNBUF
IFSE FLD,DEVICE, ERJMP JFN6BY ;IF ERROR THEN TRY DEVST
SKIPN T,PNBUF
MOVSI T,(ASCIZ \*\)
IFSE FLD,GENERATION,[
CAMN T,[ASCII \99999\]
CAME 1,[010700,,PNBUF]
JRST .+2
MOVSI T,(ASCIZ \*\)
]
PUSH FXP,T
REPEAT LEN-1, PUSH FXP,PNBUF+1+.RPCNT
LSH 3,-3
TERMIN
.SEE JS%DEV JS%DIR JS%NAM JS%TYP JS%GEN
JFN6BX: JUMPN R,JFN6BZ ;NON-ZERO ==> ENTRY FROM JFN6BT
MOVEI 1,(2)
RLJFN ;RELEASE THE JFN FOR NMS6BT
HALT
JFN6BZ: PUSH FXP,F ;PUSH LOCKI WORD BACK
UNLKPOPJ
JFN6BY: MOVEI T,[SIXBIT \DEVICE FAILURE IN NAMESTRING!\]
CAIE 2,.PRIIN ;PRIMARY INPUT?
CAIN 2,.PRIOU ;OR PRIMARY OUTPUT
SKIPA ;YES
JRST JFN6ER ;NOPE, FAIL
PUSH FXP,[ASCII/PRIMA/]
PUSH FXP,[ASCIZ/RY/]
PUSHN FXP,\<<L.6DEV-2>+L.6DIR+L.6FNM+L.6EXT+L.6VRS>
JRST JFN6BX
JFN6ER: MOVE FXP,D ;FLUSH ALL CRUD OFF FXPDL
PUSH FXP,F ;PUSH LOCKI WORD BACK
JUMPE R,NMS6BB ;FOR NMS6BT, GO GIVE WTA ERROR
AOS (P) ;FOR JFN6BT, SKIP ON FAILURE
UNLKPOPJ
LFGB20: GJ%ACC+GJ%OFG+GJ%FLG 99999. ;BLOCK FOR LONG FORM OF GTJFN
.NULIO,, .NULIO
REPEAT,4 440700,, R70 ;DEFAULT STRINGS FOR dev:<dir>fnm.ext
REPEAT 3, 0
LFGB10: GJ%ACC+GJ%OFG+GJ%FLG -3 ;BLOCK FOR LONG FORM OF GTJFN
.NULIO,, .NULIO
0 ;DEFAULT THE DEVICE TO CONNECTED ONE
REPEAT,0 440700,, R70 ;DEFAULT STRINGS FOR <dir>fnm.ext
REPEAT 3, 0
] ;END OF IFN D20
;IFL6BT FILSFA FIL6BT FIL6B0 FIL6DF FIL6B1 FIL6B2 QIOSAV LQIOSV
SUBTTL CONVERSION: ANY FILE SPEC => SIXBIT
;;; TAKE ARGUMENT IN A (MAY BE FILE ARRAY, NAMELIST,
;;; OR NAMESTRING), FIGURE IT OUT AND SOMEHOW RETURN
;;; "SIXBIT" FORMAT ON FXP.
;;; IFL6BT SAYS THAT T MEANS TTY INPUT, NOT TTY OUTPUT.
;;; SAVES C AR1 AR2A
IFL6BT: CAIN A,TRUTH
HRRZ A,V%TYI
JRST FIL6B0
IFN SFA,[
FILSFA: MOVEI B,QNAME ;EXTRACT THE "FILENAME" FROM THE SFA
SETZ C, ;NO ARGS
PUSHJ P,ISTCSH ;SHORT CALL, THEN USE RESULT AS NEW NAME
] ;END IFN SFA
FIL6BT: CAIN A,TRUTH
HRRZ A,V%TYO
FIL6B0: SKIPN A ;NIL => USE "DEFAULTF"
FIL6DF: HRRZ A,VDEFAULTF ;USE "DEFAULTF"
FIL6B1: MOVEI R,(A)
LSH R,-SEGLOG
SKIPGE R,ST(R)
JRST NML6BT ;LIST => NAMELIST
TLNN R,SA
JRST FIL6B2 ;NOT ARRAY => NAMESTRING
MOVE R,ASAR(A)
SFA$ TLNE R,AS.SFA ;AN SFA?
SFA$ JRST FILSFA ;YES, EXTRACT NAME FROM IT AND TRY AGAIN
TLNN R,AS<JOB+FIL>
JRST NMS6B0 ;INCOMPREHENSIBLE NAMESTRING
LOCKI ;FOR FILE, GOBBLE NAMES OUT OF FILE OBJECT
POP FXP,D ;POP LOCKI WORD
MOVE TT,TTSAR(A)
ADDI TT,F.DEV
HRLI TT,-L.F6BT
PUSH FXP,(TT) ;PUSH ALL WORDS OF FILE SPEC
AOBJN TT,.-1
PUSH FXP,D ;PUSH BACK LOCKI WORD
UNLKPOPJ ;UNLOCK AND EXIT
FIL6B2: JSP T,QIOSAV
JRST NMS6BT
QIOSAV: SAVE B C AR1 AR2A
PUSHJ P,(T)
RSTR AR2A AR1 C B
POPJ P,
LQIOSV==5 ; 5 THINGS - 4 AC'S AND ONE RET ADDR
.SEE 6BTNS8 ;RELIES ON AC C BEING SAVED IN CERTAIN SPOT
;MERGEF MRGF1 DMRGF ZZZ ZZZ DMRGF5 IMRGF MRGF2 C6BTNML TRUENAME TRUNMZ TRU6BT TRUNM2 TRUNM8 TRUNM9 TRUNM0 SUREAD SUWRITE
SUBTTL MERGEF, TRUENAME, PROBEF AND MERGING ROUTINES
;;; MERGEF TAKES TWO FILE SPECS OF ANY KIND, MERGES THEM,
;;; AND RETURNS A NAMELIST OF THE RESULTING SPECS.
;;; AS A CROCK, (MERGEF X '*) SIMPLY MAKES THE SECOND
;;; FILE NAME (FOR D20, THE VERSION) BE *.
MERGEF: PUSH P,B
PUSHJ P,FIL6BT
POP P,A
CAIE A,Q.
JRST MRGF1
20% MOVSI T,(SIXBIT \*\)
20% MOVEM T,(FXP)
20$ REPEAT L.6VRS, SETZM -.RPCNT(FXP)
JRST 6BTNML
MRGF1: PUSHJ P,FIL6BT
PUSHJ P,IMRGF
JRST 6BTNML
;;; IMRGF MERGES TWO SETS OF SPECS ON THE FIXNUM PDL.
;;; DMRGF MERGES A SET WITH THE DEFAULT FILE NAMES.
;;; DEC-10 PPN'S MERGE HALVES OF THE PPN SEPARATELY;
;;; AN UNSPECIFIED HALF IS -1 OR 0, *NOT* (SIXBIT \*\)!!
;;; SAVES F (SEE LOAD).
DMRGF:
;FIRST SEE WHETHER WE REALLY NEED TO CONVERT THE DEFAULTS TO "SIXBIT"
IFN ITS+D10,[
MOVSI TT,(SIXBIT \*\)
REPEAT L.F6BT,[
IFN ITS\<.RPCNT-1>,[
CAME TT,.RPCNT-3(FXP) ;MUST MERGE IF FILE NAME IS ZERO OR *
SKIPN .RPCNT-3(FXP)
JRST DMRGF5
] ;END OF IFN ITS\<.RPCNT-1>
.ELSE,[
MOVE T,.RPCNT-3(FXP)
TLCE T,-1
TLNN T,-1
JRST DMRGF5
TRCE T,-1
TRNN T,-1
JRST DMRGF5
] ;END OF .ELSE
] ;END OF REPEAT L.F6BT
] ;END OF IFN ITS+D10
IFN D20,[
MOVSI TT,(ASCII \*\)
ZZZ==0
IRP FOO,,[L.6VRS,L.6EXT,L.6FNM,L.6DIR,L.6DEV]
ZZZ==ZZZ+FOO
CAME TT,-ZZZ+1(FXP)
SKIPN -ZZZ+1(FXP)
JRST DMRGF5
TERMIN
EXPUNGE ZZZ
] ;END OF IFN D20
POPJ P, ;MERGE WOULDN'T DO ANYTHING - FORGET IT
DMRGF5: PUSH FLP,F ;MERGE WITH DEFAULT FILE NAMES
HRRZ A,VDEFAULTF
PUSHJ P,FIL6BT
POP FLP,F
IMRGF:
IFN ITS+D10,[
MOVEI T,L.F6BT ;MERGE TWO SETS OF NAMES ON FXP
MOVSI TT,(SIXBIT \*\)
MRGF2:
10$ MOVE R,D
POP FXP,D
10$ CAIE T,2 ;PPN IS PENULTIMATE FROB - DON'T COMPARE TO *
CAME TT,-3(FXP)
SKIPN -3(FXP)
MOVEM D,-3(FXP)
SOJG T,MRGF2
10$ MOVE D,-2(FXP) ;R HAS PPN 2 - GET PPN 1 IN D
10$ TLCE D,-1 ;IF 0
10$ TLNN D,-1 ;OR -1
10$ HLLM R,-2(FXP) ;DEFAULT
10$ TRCE D,-1
10$ TRNN D,-1
10$ HRRM R,-2(FXP)
] ;END OF IFN ITS+D10
IFN D20,[
MOVSI TT,(ASCII \*\)
IRP FOO,,[VRS,EXT,FNM,DIR,DEV]
CAME TT,-L.6!FOO-L.F6BT+1(FXP)
SKIPN -L.6!FOO-L.F6BT+1(FXP)
JRST IM!FOO!1
POPI FXP,L.6!FOO
JRST IM!FOO!2
IM!FOO!1:
IFLE L.6!FOO-3, REPEAT L.6!FOO, POP FXP,-L.F6BT(FXP)
.ELSE,[
MOVEI T,L.6!FOO
POP FXP,-L.F6BT(FXP)
SOJG T,.-1
] ;END OF .ELSE
IM!FOO!2:
TERMIN
] ;END OF IFN D20
C6BTNML: POPJ P,6BTNML
;;; (TRUENAME <FILE>) RETURNS THE RESULT OF .RCHST ON ITS,
;;; I.E. THE REAL FILE NAMES AFTER TRANSLATIONS, LINKS, ETC.
;;; THE RESULT IS A NAMELIST.
TRUENAME:
IFN SFA,[
EXCH AR1,A
JSP TT,XFOSP ;FILE OR SFA OR NOT?
JRST TRUNM9 ;NOT
JRST TRUNMZ ;FILE
EXCH A,AR1
JSP T,QIOSAV
MOVEI B,QTRUENAME
SETZ C, ;NO THIRD ARG
JRST ISTCSH ;SHORTY INTERNAL STREAM CALL
TRUNMZ: EXCH A,AR1
] ;END IFN SFA
PUSH P,C6BTNML ;SUBR 1
TRU6BT: CAIN A,TRUTH ;MUST SAVE AR1 - SEE PRNF6-PRNJ2
HRRZ A,V%TYO
TRUNM2: EXCH AR1,A
LOCKI
JSP TT,XFILEP
JRST TRUNM8
EXCH A,AR1
HRRZ TT,TTSAR(A)
IFN ITS+D10,[
POP FXP,T ;POP THE LOCKI WORD
HRLI TT,-L.F6BT
PUSH FXP,F.RDEV(TT)
AOBJN TT,.-1
PUSH FXP,T ;PUSH LOCKI WORD BACK
UNLKPOPJ
] ;END OF ITS+D10
IFN D20,[
PUSH P,A
MOVE 1,F.JFN(TT)
PUSHJ P,JFN6BT ;GET "SIXBIT" ON FXP, AND UNLOCKI
JRST POPAJ ; ON SUCCESS, LEAVES "SIXBIT" FORMS ON FXPDL
POP P,A
JRST TRUNM0
] ;END OF IFN D20
TRUNM8: UNLOCKI
TRUNM9: EXCH AR1,A
TRUNM0: %WTA NFILE ;NOT FILE
SFA$ MOVE T,C6BTNML ;IF NOT CALLED AS A SUBR, ONLY ACCEPT A FILE
SFA$ CAME T,(P)
JRST TRUNM2
SFA$ POPI P,1
SFA$ JRST TRUENAME
;;; (STATUS UREAD)
SUREAD: SKIPN A,VUREAD
POPJ P,
PUSHJ P,TRUENAME
HLRZ B,(A)
HRRZ A,(A)
HRRZ C,(A)
20$ HRRZ C,(C)
20$ HRRM C,(A)
HRRM B,(C)
POPJ P,
;;; (STATUS UWRITE)
SUWRITE: SKIPE A,VUWRITE
PUSHJ P,TRUENAME
JRST $CAR ;(CAR NIL) => NIL
;2MERGE PROBEF PROBEZ PROBF0 D10RFN PROBF6 PROBF8 PROBF9
;;; ROUTINE TO SET UP ARGS FOR TWO-ARGUMENT FILE FUNCTION.
;;; PUT TWO SETS OF FILE NAMES ON FXP. IF THE ARGS ARE
;;; X AND Y, THEN THE NAMES ON FXP ARE (MERGEF X NIL) AND
;;; (MERGEF Y (MERGEF X NIL)). THE FIRST ARG IS LEFT IN AR1.
2MERGE: PUSH P,A
PUSH P,B
PUSHJ P,FIL6BT
PUSHJ P,DMRGF
POP P,A
PUSHJ P,FIL6BT
MOVEI T,L.F6BT
PUSH FXP,-2*L.F6BT+1(FXP)
SOJG T,.-1
PUSHJ P,IMRGF ;NOW WE HAVE THE MERGED FILE SPECS
POP P,AR1 ;FIRST ARG
POPJ P,
;;; (PROBEF X) TRIES TO DECIDE WHETHER FILE X EXISTS.
;;; ON ITS AND D10 THIS IS DONE BY TRYING TO OPEN THE FILE.
;;; ON D20 WE USE THE GTJFN JSYS.
;;; RETURNS REAL FILE NAMES ON SUCCESS, NIL ON FAILURE.
PROBEF: ;SUBR 1
IFN SFA,[
JSP TT,AFOSP ;DO WE HAVE AN SFA?
JRST PROBEZ ;NOPE
JRST PROBEZ ;NOPE
MOVEI B,QPROBEF ;PROBEF OPERATION
SETZ C, ;NO ARGS
JRST ISTCSH ;SHORT CALL, RETURN RESULTS
PROBEZ: ] ;END IFN SFA
PUSHJ P,FIL6BT
PROBF0: PUSHJ P,DMRGF
IFN ITS,[
LOCKI
SETZ TT, ;ASSUME NO CONTROL ARG
MOVSI T,'USR ;CHECK FOR USR DEVICE
CAMN T,-3-1(FXP) ;MATCH?
TRO TT,10 ;SET BIT 1.4 (INSIST ON EXISTING JOB)
.CALL PROBF8
JRST PROBF6
.CALL PROBF9
.LOSE 1400
.CLOSE TMPC,
UNLOCKI
] ;END OF IFN ITS
IFN D10,[
LOCKI
MOVEI T,.IODMP ;I/O MODE (DUMP MODE)
MOVE TT,-3-1(FXP) ;DEVICE NAME
SETZ D,
OPEN TMPC,T
JRST PROBF6 ;NO SUCH FILE IF NO SUCH DEVICE!
IFE SAIL,[
MOVEI T,3 ;ONLY NEED 3 ARGS OF EXTENDED LOOKUP
MOVE D,-1-1(FXP) ;FILE NAME
HLLZ R,0-1(FXP) ;EXTENSION
MOVE TT,-2-1(FXP) ;PPN
] ;END IFE SAIL
IFN SAIL,[
MOVE T,-1-1(FXP) ;FILE NAME
HLLZ TT,0-1(FXP) ;EXTENSION
CAMN TT,[SIXBIT \←←←\]
SETZ TT,
SETZ D, ;UNUSED
MOVE R,-2-1(FXP) ;PPN
] ;END IFN SAIL
LOOKUP TMPC,T
JRST PROBF5 ;FILE DOESN'T EXIST
PUSHJ P,D10RFN ;READ BACK FILE NAMES
RELEASE TMPC, ;RELEASE TEMP CHANNEL
UNLOCKI
JRST 6BTNML ;FORM NAMELIST ON SUCCESS
D10RFN: MOVEI F,TMPC ;WE WILL GET DEVICE NAME FROM MONITOR
SA% DEVNAM F,
SA$ PNAME F,
SKIPA ;NONE SO RETAIN OLD NAME
MOVEM F,-3-1(FXP) ;ELSE STORE NEW DEVICE NAME
IFE SAIL,[
MOVEM TT,-2-1(FXP) ;STORE DATA AS RETURNED FROM EXTENDED LOOKUP
MOVEM D,-1-1(FXP)
HLLZM R,0-1(FXP)
] ;END IFE SAIL
IFN SAIL,[
MOVEM T,-1-1(FXP) ;SAIL HAS NO EXTENDED LOOKUP!!!!!
HLLZM TT,0-1(FXP) ; SO, WE CAN'T STORE PPN; JUST ASSUME IT IS
; WHAT WE GAVE IT
] ;END IFN SAIL
POPJ P,
] ;END OF IFN D10
IFN D20,[
PUSHJ P,6BTNSL ;GET NAMESTRING IN PNBUF
LOCKI
MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT) .SEE .GJDEF
MOVE 2,PNBP
GTJFN ;GET A JFN (INSIST ON EXISTING FILE)
JRST UNLKFALSE
PUSH FLP,1 ;SAVE JFN OVER JFN6BT
PUSHJ P,JFN6BT ;CONVERT JFN TO "SIXBIT" FORMAT ON FXP
TDZA B,B
MOVEI B,TRUTH ;SKIPS ON FAILURE
POP FLP,1
RLJFN ;RELEASE THE JFN
HALT
JUMPN B,FALSE
] ;END OF IFN D20
10% JRST 6BTNML
IFN ITS+D10,[
10$ PROBF5: RELEASE TMPC,
PROBF6: UNLOCKI
POPI FXP,L.F6BT ;POP "SIXBIT" CRUD FROM FXP
JRST FALSE ;RETURN FALSE ON FAILURE
] ;END OF IFN ITS+D10
IFN ITS,[
PROBF8: SETZ
SIXBIT \OPEN\ ;OPEN FILE (ASCII UNIT INPUT)
4000,,TT ;CONTROL ARG (DON'T CREATE BIT SET FOR USR)
1000,,TMPC ;CHANNEL #
,,-3-1(FXP) ;DEVICE NAME
,,-1-1(FXP) ;FILE NAME 1
,,0-1(FXP) ;FILE NAME 2
400000,,-2-1(FXP) ;SNAME
PROBF9: SETZ
SIXBIT \RFNAME\ ;READ REAL FILE NAMES
1000,,TMPC ;CHANNEL #
2000,,-3-1(FXP) ;DEVICE NAME
2000,,-1-1(FXP) ;FILE NAME 1
2000,,0-1(FXP) ;FILE NAME 2
402000,,-2-1(FXP) ;SNAME
] ;END OF IFN ITS
;$RENAMEF RENAM1 RENAM0 RENM0A RENM0B RENM1A RENAM2 RENM2A RENAM7 RENAM8 RENAM4 RENAM5 RNAM5A RENAM4 RENAM5 RENAM6 RENAM9 XCIOL RFNAME CNAMEF CNAME3 CNAME2 CNAME1 CNAMER CNAER1 CNAER2
SUBTTL RENAMEF FUNCTION, CNAMEF FUNCTION
;;; (RENAMEF X Y) RENAMES (MERGEF X (NAMELIST NIL)) TO BE
;;; (MERGEF Y (MERGEF X (NAMELIST NIL))).
;;; IF X IS AN OUTPUT FILE ARRAY, IT IS RENAMED AND CLOSED.
$RENAMEF:
PUSHJ P,2MERGE ;2MERGE LEAVES ARG 1 IN AR1
MOVEI A,(AR1)
HLLOS NOQUIT
JSP TT,XFILEP ;SKIP IF FILE ARRAY
JRST RENAM2
MOVE TT,TTSAR(A)
HLL AR1,TT
TLNE TT,TTS.CL
JRST RENM2A
IFN D10+ITS,[
PUSHJ P,JCLOSE
IFN ITS,[
.CALL RENAM7 ;ITS RENAME! - MUST RENAME WHILE OPEN
IOJRST 0,RENAM6
] ;END OF IFN ITS
IFN D10,[
MOVE F,F.CHAN(TT) ;ttsar left in TT by JCLOSE
MOVE T,-1(FXP) ;D10 RENAME! - will construct instruction
HLLZ TT,(FXP)
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
MOVE R,-2(FXP)
LSH F,27
IOR F,[RENAME 0,T]
XCT F
IOJRST 0,RENAM6
] ;END OF IFN D10
RENAM1: MOVE TT,TTSAR(A)
MOVE D,-1(FXP) ;UPDATE THE FILE NAMES OF ARRAY
MOVEM D,F.FN1(TT)
10% MOVE R,(FXP)
10$ HLLZ R,(FXP)
MOVEM R,F.FN2(TT)
IFN D10,[
MOVEM D,F.RFN1(TT) ;TRUENAMES for D10, and CLOSE/RELEASE
MOVEM F,F.RFN2(TT)
MOVE R,-2(FXP)
MOVEM R,F.PPN(TT)
MOVEM R,F.RPPN(TT)
SA$ XOR F,[<CLOSE 0,0>#<RENAME 0,T>]
SA$ XCT F
SA$ XOR F,[<RELEASE 0,0>#<CLOSE 0,0>]
SA% XOR F,[<RELEASE 0,0>#<RENAME 0,T>]
XCT F
] ;END OF IFN D10
IFN ITS,[
.CALL RFNAME ;TRUENAMES for ITS and CLOSE file
.LOSE 1400
.CALL CLOSE9
.LOSE 1400
] ;END OF IFN ITS
] ;END OF IFN D10+ITS
IFN D20,[
PUSH P,F.JFN(TT)
PUSHJ P,JCLOSE
RENAM0: PUSHJ P,X6BTNSL
POP P,T
MOVSI 1,(GJ%FOU+GJ%NEW+GJ%ACC+GJ%SHT)
MOVE 2,PNBP
GTJFN
IOJRST 0,RENAM5
MOVEI 2,(1)
JUMPE AR1,RENM0A
TLNE AR1,TTS.CL ;THE "CLOSED" BIT WAS TRANSFERRED
JRST RENM0A
MOVEI 1,(T)
HRLI 1,(CO%NRJ)
CLOSF
IOJRST 0,RENAM4
RENM0A: MOVEI 1,(T)
RNAMF
IOJRST 0,RENAM4
MOVE 1,2
RLJFN ;? SHOULD GC DO THE RELEASE?
HALT
JUMPE AR1,RENM0B
MOVE TT,TTSAR(AR1)
MOVEI T,F.DEV(TT)
HRLI T,-L.F6BT+1(FXP)
BLT T,F.DEV+L.F6BT-1(TT)
RENM0B: JUMPE AR1,RENM1A
] ;END OF IFN D20
POPI FXP,L.F6BT ;WHEN 1ST ARG IS FILE ARRAY, THEN RETURN THAT
SKIPA A,AR1
RENM1A: PUSHJ P,6BTNML ;OTHERWISE, RET VAL IS THE (NEW) NAMELIST
POPI FXP,L.F6BT
JRST CZECHI
RENAM2: MOVEI AR1,NIL ;FILE TO BE RENAMED IS SPECIFIED BY NAMELIST
; OR NAMESTRING
RENM2A: ;SPECIFIED BY A CLOSED FILE ARRAY
IFN ITS,[
.CALL RENAM8 ;ORDINARY RENAME
IOJRST 0,RENAM6
JRST RENM1A
] ;END OF IFN ITS
IFN D10,[
MOVEI T,.IODMP ;TO RENAME A FILE, WE OPEN A DUMP MODE CHANNEL
MOVE TT,-7(FXP) ;GET DEVICE NAME
SETZ D,
OPEN TMPC,T ;OPEN CHANNEL
JRST RENAM4
MOVE T,-5(FXP) ;FILE NAME
HLLZ TT,-4(FXP) ;EXTENSION
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
MOVE R,-6(FXP) ;PPN
LOOKUP TMPC,T ;LOOK UP FILE
IOJRST 0,RENAM5
MOVE T,-1(FXP) ;NEW FILE NAME
HLLZ TT,(FXP) ;NEW EXTENSION
SETZ D,
MOVE R,-2(FXP) ;NEW PPN
RENAME TMPC,T ;RENAME FILE
IOJRST 0,RENAM5
RELEASE TMPC,
JUMPE AR1,RENM1A
JRST RENAM1
] ;END OF IFN D10
IFN D20,[
MOVEI T,L.F6BT
PUSH FXP,-2*L.F6BT+1(FXP) ;COPY OLD FILE NAMES TO TOP OF FXP
SOJG T,.-1
PUSHJ P,6BTNSL ;STRING OUT INTO PNBUF
PUSH P,A
MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT)
MOVE 2,PNBP
GTJFN ;GET A JFN FOR OLD FILE NAMES
IOJRST 0,RENAM6
EXCH 1,(P) ;PUSH JFN, AND RESTORE ACC A
JRST RENAM0 ; AND JOIN GENERAL RENAME
] ;END OF IFN D20
IFN ITS,[
RENAM7: SETZ
SIXBIT \RENMWO\ ;RENAME WHILE OPEN
,,F.CHAN(TT) ;CHANNEL #
,,-1(FXP) ;NEW FILE NAME 1
400000,,(FXP) ;NEW FILE NAME 2
RENAM8: SETZ
SIXBIT \RENAME\ ;RENAME
,,-7(FXP) ;DEVICE NAME
,,-5(FXP) ;OLD FILE NAME 1
,,-4(FXP) ;OLD FILE NAME 2
,,-6(FXP) ;SNAME
,,-1(FXP) ;NEW FILE NAME 1
400000,,(FXP) ;NEW FILE NAME 2
] ;END OF IFN ITS
IFN D20,[
RENAM4: MOVE 1,2
RLJFN
HALT
RENAM5: JUMPE AR1,RNAM5A
TLNE AR1,TTS.CL ;THE "CLOSED" BIT WAS TRANSFERRED
JRST RNAM5A
MOVEI 1,(T)
HRLI 1,(CO%NRJ)
CLOSF
IOJRST 0,RNAM5A
RNAM5A: MOVE 1,T
RLJFN
HALT
] ;END OF IFN D20
IFN D10,[
RENAM4: SKIPA C,[NSDERR]
RENAM5: RELEASE TMPC,
] ;END OF IFN D10
RENAM6: PUSHJ P,CZECHI
RENAM9: PUSHJ P,6BTNML ;ERROR MESSAGE IS IN C
PUSHJ P,NCONS
PUSH P,A
PUSHJ P,6BTNML
POP P,B
PUSHJ P,CONS
MOVEI B,Q$RENAMEF
XCIOL: PUSHJ P,XCONS ;XCONS, THEN IOL
%IOL (C)
10$ NSDERR: SIXBIT \NO SUCH DEVICE!\
IFN ITS,[
RFNAME: SETZ
SIXBIT \RFNAME\ ;READ FILE NAMES
,,F.CHAN(TT) ;CHANNEL #
2000,,F.RDEV(TT) ;DEVICE NAME
2000,,F.RFN1(TT) ;FILE NAME 1
2000,,F.RFN2(TT) ;FILE NAME 2
402000,,F.RSNM(TT) ;SNAME
] ;END OF IFN ITS
CNAMEF: PUSHJ P,2MERGE ;LEAVES FIRST ARG IN AR1
JSP TT,XFILEP
JRST CNAME1
MOVE TT,TTSAR(AR1)
TLNN TT,TTS.CL ;FILE-ARRAY MUST BE CLOSED
JRST CNAME2
ADDI TT,L.F6BT
MOVEI F,L.F6BT ;COUNTER TO TRANSFER WORDS
CNAME3: MOVE T,(FXP)
MOVEM T,F.DEV-1(TT)
20$ POPI FXP,1
20% POP FXP,F.RDEV-1(TT)
SUBI TT,1
SOJG F,CNAME3
POPI FXP,L.F6BT
MOVEI A,(AR1)
POPJ P,
CNAME2: SKIPA C,[CNAER2]
CNAME1: MOVEI C,CNAER1
CNAMER: PUSHJ P,6BTNML ;ERROR MESSAGE IS IN C
PUSHJ P,NCONS
PUSH P,A
PUSHJ P,6BTNML
POP P,B
PUSHJ P,CONS
MOVEI B,QCNAMEF
PUSHJ P,XCONS ;XCONS, THEN IOL
%IOL (C)
CNAER1: SIXBIT/NOT FILE ARRAY!/
CNAER2: SIXBIT/FILE ARRAY NOT CLOSED!/
;$DELETEF $DELNS $DEL6 $DEL3 $DEL7 $DEL5 $DEL4 $DEL5 $DEL9 $DEL9A
SUBTTL DELETEF FUNCTION
;;; (DELETEF X) DELETES THE FILE X. (THAT SOUNDS LOGICAL...)
$DELETEF: ;SUBR 1
JSP TT,AFOSP ;SKIP IF FILE OR SFA
JRST $DEL3
IFN SFA,[
JRST $DELNS ;A FILE, NOT AN SFA
MOVEI B,Q$DELETE ;DELETE OPERATION
SETZ C, ;NO OP SPECIFIC ARG
JRST ISTCSH ;FAST INTERNAL SFA CALL
$DELNS: ] ;END IFN SFA
MOVE TT,TTSAR(A)
TLNE TT,TTS.CL ;SKIP IF OPEN
JRST $DEL3
HLLOS NOQUIT
IFN ITS,[
.CALL $DEL6 ;USE DELEWO FOR AN OPEN FILE
IOJRST 0,$DEL9A
PUSHJ P,JCLOSE
MOVE T,F.CHAN(TT) ;CHANNEL INTO T FOR CLOSE9
.CALL CLOSE9 ;ACTUALLY PERFORM THE CLOSE
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
MOVE F,F.CHAN(TT)
MOVE R,F.RPPN(TT)
LSH F,27
IOR F,[RENAME 0,T]
SETZB T,TT
XCT F
IOJRST 0,$DEL9A
PUSHJ P,JCLOSE
XOR F,[<CLOSE 0,40>#<RENAME 0,T>]
XCT F ;40 BIT MEANS AVOID SUPERSEDING A FILE
XOR F,[<RELEASE 0,0>#<CLOSE 0,40>]
XCT F
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT)
HRLI 1,(CO%NRJ) ;DON'T RELEASE JFN
PUSHJ P,JCLOSE
CLOSF
IOJRST 0,$DEL9A
TLZ 1,-1
DELF
IOJRST 0,$DEL9A
] ;END OF IFN D20
JRST CZECHI
IFN ITS,[
$DEL6: SETZ
SIXBIT \DELEWO\ ;DELETE WHILE OPEN
400000,,F.CHAN(TT) ;CHANNEL #
] ;END OF IFN ITS
$DEL3: PUSHJ P,FIL6BT
PUSHJ P,DMRGF ;MERGE ARG WITH DEFAULTS
IFN ITS,[
.CALL $DEL7
IOJRST 0,$DEL9
] ;END OF IFN ITS
IFN D10,[
MOVEI T,.IODMP
MOVE TT,-3(FXP) ;GET DEVICE NAME
SETZ D,
OPEN TMPC,T ;OPEN TEMP DUMP MODE CHANNEL
JRST $DEL4
MOVE T,-1(FXP) ;FILE NAME
HLLZ TT,(FXP) ;EXTENSION
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
MOVE R,-2(FXP) ;PPN
LOOKUP TMPC,T
IOJRST 0,$DEL5
SETZB T,TT ;ZERO FILE NAMES MEANS DELETE
MOVE R,-2(FXP) ;MUST SPECIFY CORRECT PPN
RENAME TMPC,T ;DELETE THE FILE
IOJRST 0,$DEL5
RELEASE TMPC, ;RELEASE TEMP CHANNEL
] ;END OF IFN D10
IFN D20,[
PUSHJ P,X6BTNSL ;GET NAMESTRING FOR FILE IN PNBUF
MOVE 1,[GJ%OLD+GJ%ACC+GJ%SHT+.GJLEG]
MOVE 2,PNBP
GTJFN ;GET A JFN FOR THE FILE
IOJRST 0,$DEL9
TLZ 1,-1
DELF ;DELETE IT
IOJRST 0,$DEL5
] ;END OF IFN D20
JRST 6BTNML
IFN ITS,[
$DEL7: SETZ
SIXBIT \DELETE\ ;DELETE FILE
,,-3(FXP) ;DEVICE NAME
,,-1(FXP) ;FILE NAME 1
,,0(FXP) ;FILE NAME 2
400000,,-2(FXP) ;SNAME
] ;END OF IFN ITS
IFN D20,[
$DEL5: RLJFN ;RELEASE THE TEMP JFN
HALT
] ;END OF IFN D20
IFN D10,[
$DEL4: SKIPA C,[NSDERR]
$DEL5: RELEASE TMPC, ;RELEASE THE TEMP CHANNEL
] ;END OF IFN D10
$DEL9: PUSHJ P,6BTNML
$DEL9A: PUSHJ P,CZECHI
PUSHJ P,ACONS
MOVEI B,Q$DELETEF
JRST XCIOL
;CLOSE0 $CLOSE ICLOSE ICLOS6 CLOSE9 JCLOSE CLOSE4
SUBTTL CLOSE FUNCTION
;;; (CLOSE X) CLOSES THE FILE ARRAY X. THE ARRAY ITSELF
;;; IS *NOT* FLUSHED - MAY WANT TO RE-OPEN IT.
CLOSE0:
SFA% WTA [NOT FILE - CLOSE!]
SFA$ WTA [NOT FILE OR SFA - CLOSE!]
$CLOSE: JSP TT,AFOSP ;LEAVES OBJECT IN A
JRST CLOSE0 ;NOT A FILE
IFN SFA,[
JRST ICLOSE ;A FILE-ARRAY, DO INTERNAL STUFF
MOVEI B,Q$CLOSE ;CLOSE OPERATION
SETZ C, ;NO THIRD ARG
JRST ISTCSH ;SHORT INTERNAL SFA CALL
] ;END IFN SFA
ICLOSE: HLLOS NOQUIT
MOVE TT,TTSAR(A)
TLNE TT,TTS.CL
JRST ICLOS6
PUSHJ P,JCLOSE
IFN ITS,[
.CALL CLOSE9 ;CLOSE FILE
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
LSH T,27
SA$ IOR T,[CLOSE 0,0]
SA$ XCT T
SA$ XOR T,[<RELEASE 0,0>#<CLOSE 0,0>]
SA% IOR T,[RELEASE 0,0]
XCT T
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT)
CLOSF ;DOES AN IMPLICIT RLJFN
JFCL
] ;END OF IFN D20
SKIPA A,[TRUTH] ;RETURN T IF DID SOMETHING, ELSE NIL
ICLOS6: MOVEI A,NIL
JRST CZECHI
CLOSE9: SETZ
SIXBIT \CLOSE\ ;CLOSE CHANNEL
401000,,(T) ;CHANNEL #
;;; FILE PRE-CLOSE CLEANUP - RETURNS CHANNEL IN T, TTSAR IN TT
JCLOSE: MOVE TT,TTSAR(A)
TLNE TT,TTS.CL ;SKIP UNLESS ALREADY CLOSED
.LOSE
TLNE TT,TTS.IO ;SKIP UNLESS OUTPUT FILE ARRAY
PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER
MOVE TT,TTSAR(A)
TLNE TT,TTS.TY
SKIPN T,FT.CNS(TT)
JRST CLOSE4
SETZM FT.CNS(TT) ;UNLINK TWO TTY'S WHICH
MOVE T,TTSAR(T) ; WERE TTYCONS'D TOGETHER
SETZM FT.CNS(T) ; IF ONE IS CLOSED
CLOSE4: HRRZ T,F.CHAN(TT)
MOVSI D,TTS.CL ;TURN ON "FILE CLOSED"
IORM D,TTSAR(A) ; BIT IN ARRAY SAR
SETZM CHNTB(T) ;CLEAR CHANNEL TABLE ENTRY
POPJ P,
;FORCE FORSF1 FORCE1 FORCE9 IFORCE IFORC1 FORCE6 IOTTTT SIOT
SUBTTL FORCE-OUTPUT
;;; (FORCE-OUTPUT X) FORCES THE OUTPUT BUFFER OF OUTPUT FILE ARRAY X.
FORCE:
IFN SFA,[
EXCH AR1,A
JSP TT,XFOSP ;AN SFA?
JRST FORSF1
JRST FORSF1
EXCH AR1,A
JSP T,QIOSAV
MOVEI B,QFORCE
SETZ C,
JRST ISTCSH
FORSF1: EXCH AR1,A
] ;END IFN SFA
PUSH P,AR1
MOVEI AR1,(A)
PUSHJ P,FORCE1
POP P,AR1
POPJ P,
FORCE1: PUSHJ P,OFILOK ;DOES A LOCKI
PUSHJ P,IFORCE
IFN ITS,[
.CALL FORCE9
CAIN D,%EBDDV ;"WRONG TYPE DEVICE" ERROR IS OKAY
CAIA
.VALUE ;ANY OTHER ERROR LOSES
] ;END OF IFN ITS
JRST UNLKTRUE
IFN ITS,[
FORCE9: SETZ
SIXBIT \FORCE\ ;FORCE OUTPUT BUFFER TO DEVICE
,,F.CHAN(TT) ;CHANNEL #
403000,,D ;ERROR #
] ;END OF IFN ITS
;;; INTERNAL OUTPUT BUFFER FORCE ROUTINE. EXPECTS USER
;;; INTERRUPTS OFF, AND FILE ARRAY TTSAR IN TT.
;;; CLOBBERS T, TT, D, AND F.
IFORCE: TLNE TT,TTS.CL
LERR [SIXBIT \CAN'T FORCE OUTPUT ON CLOSED FILE!\]
SKIPGE F,F.MODE(TT) .SEE FBT.CM ;CAN'T FORCE A CHARMODE FILE
POPJ P,
MOVE F,FB.BFL(TT)
IFN ITS,[
SUB F,FB.CNT(TT)
JUMPE F,IFORC1
MOVE D,F ;NUMBER OF BYTES TO TRANSFER
MOVE T,FB.IBP(TT) ;INITIAL BYTE POINTER
.CALL SIOT ;OUTPUT THE (PARTIAL) BUFFER
.LOSE 1400
IFORC1:
] ;END OF IFN ITS
IFN D10,[
MOVE T,F.CHAN(TT)
LSH T,27
IOR T,[OUT 0,0]
XCT T ;OUTPUT THE CURRENT BUFFER
CAIA
HALT ;? OUTPUT ERROR
] ;END OF IFN D10
IFN D20,[
SUB F,FB.CNT(TT)
PUSHJ FXP,SAV3 ;PRESERVE ACS 1-3
MOVE 1,F.JFN(TT)
MOVE 2,FB.IBP(TT) ;INITIAL BYTE POINTER
MOVN 3,F ;NEGATIVE OF BYTE COUNT
SOUT ;OUTPUT (PARTIAL) BUFFER
ERJMP .+1 ;IGNORE ERRORS
PUSHJ FXP,RST3
] ;END OF IFN D20
ADDM F,F.FPOS(TT) ;UPDATE FILE POSITION
IFN ITS+D20, JSP D,FORCE6 ;INITIALIZE POINTER AND COUNT
POPJ P,
IFN ITS+D20,[
FORCE6: MOVE T,FB.BFL(TT) ;ROUTINE TO INITIALIZE BYTE POINTER AND COUNT
MOVEM T,FB.CNT(TT)
MOVE T,FB.IBP(TT)
MOVEM T,FB.BP(TT)
JRST (D)
];END IFN ITS+D20
IFN ITS,[
IOTTTT: SETZ
SIXBIT \IOT\ ;I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
400000,,T ;DATA POINTER (DATA?)
SIOT: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
,,T ;BYTE POINTER
400000,,D ;BYTE COUNT
] ;END OF IFN ITS
;SFMD0 SFILEMODE SFMD0A SFMD1
SUBTTL STATUS FILEMODE
;;; (STATUS FILEMODE <FILE> ) RETURNS A LIST DESCRIBING
;;; THE FILE: NIL ==> FILE HAS BEEN CLOSED; OTHERWISE
;;; THE CAR OF THIS LIST IS A VALID OPTIONS
;;; LIST FOR THE OPEN FUNCTION. THE CDR OF THIS LIST
;;; CONTAINS INFORMATIVE ITEMS WHICH ARE NOT NECESSARILY
;;; USER-SETTABLE FEATURES ABOUT THE FILE.
;;; PRESENTLY SUCH GOODIES INCLUDE:
;;; RUBOUT AN OUTPUT TTY THAT CAN SELECTIVELY ERASE
;;; CURSORPOS AN OUTPUT TTY THAT CAN CURSORPOS WELL
;;; SAIL FOR AN OUTPUT TTY, HAS SAIL CHARACTER SET
;;; FILEPOS CAN FILEPOS CORRECTLY (RANDOM ACCESS)
;;; NON-FILE ARGUMENT CAUSES AN ERROR.
SFMD0: %WTA NFILE
SFILEMODE:
JSP TT,AFOSP ;MUST BE A FILE OR SFA
JRST SFMD0
IFN SFA,[
JRST SFMD0A ;IF FILE THEN HANDLE NORMALLY
SETZ C, ;IF WE GO TO THE SFA, NO THIRD ARG
MOVEI T,SO.MOD ;CAN THE SFA DO (STATUS FILEMODE)?
MOVEI TT,SR.WOM
TDNE T,@TTSAR(A) ;CAN IT DO THE OPERATION?
JRST ISTCAL ;YES, CALL THE SFA AND RETURN
MOVEI B,QWOP ;OTHERWISE, DO A WHICH-OPERATIONS
PUSHJ P,ISTCSH
PUSH P,A ;SAVE THE RESULTS
MOVEI A,QSFA
JSP T,%NCONS ;MAKE A LIST
POP P,B
JRST CONS ;RETURN ((SFA) {WHICH-OPERATIONS})
SFMD0A: ] ;END IFN SFA
LOCKI
MOVE TT,TTSAR(A) ;GET TTSAR BITS
TLNE TT,TTS.CL ;RETURN NIL IF THE FILE IS CLOSED
JRST UNLKFALSE
MOVE R,F.FLEN(TT) ;IF LENGTH > 0 THEN BLOCK MODE, ELSE SINGLE
MOVEI A,QBLOCK
SKIPGE F,F.MODE(TT) .SEE FBT.CM
MOVEI A,QSINGLE
UNLOCKI
PUSHJ P,NCONS
MOVEI B,QDSK ;TWO MAJOR TYPES - TTY OR DSK
TLNE TT,TTS.TY
MOVEI B,QTTY
PUSHJ P,XCONS
MOVEI B,Q$ASCII ;ASCII, IMAGE, OR FIXNUM
TLNE TT,TTS.IM
MOVEI B,QIMAGE
TLNN TT,TTS.IO
TLNN TT,TTS.TY
JRST SFMD1
TLNN F,FBT.FU ;INPUT TTY: FULL CHAR SET MEANS FIXNUM FILE
SFMD1: TLNE TT,TTS<BN>
MOVEI B,QFIXNUM
PUSHJ P,XCONS
MOVEI B,Q$IN ;INPUT, OUTPUT, OR APPEND MODE
TLNE TT,TTS<IO>
MOVEI B,Q$OUT
TLNE F,FBT<AP>
MOVEI B,QAPPEND
PUSHJ P,XCONS
MOVEI B,QECHO ;OTHER RANDOM MODE BITS - ECHO
TLNE F,FBT.EC
PUSHJ P,XCONS
MOVEI B,QSCROLL ;SCROLL
TLNE F,FBT.SC
PUSHJ P,XCONS
MOVEI C,(A)
SETZ A,
MOVEI B,QSAIL
TLNE F,FBT.SA ;SAIL MODE
PUSHJ P,XCONS
MOVEI B,QRUBOUT
TLNE F,FBT.SE ;RUBOUT-ABLE
PUSHJ P,XCONS
IFN USELESS*ITS,[
MOVEI B,QCURSORPOS ;CURSORPOS-ABLE
TLNE F,FBT.CP
PUSHJ P,XCONS
] ;END OF IFN USELESS*ITS
MOVEI B,QFILEPOS ;FILEPOS-ABLE
SKIPL R .SEE F.FLEN ;NEGATIVE => CAN'T FILEPOS
PUSHJ P,XCONS
MOVEI B,(C)
JRST XCONS
;LOAD LOAD5 LOAD6 LOAD7 LOAD7A LOAD8 LOAD1 LOAD3 LOAD2 LOAD4 $FASLP FASLP1 FASLP2 FASLP8 FASLP9 FASLP2 INCLUDE INCLU1 INCEOF
SUBTTL LOAD FUNCTION
;;; (LOAD FOO) LOADS THE FILE FOO. IT FIRST PROBEF'S TO
;;; ASCERTAIN THE EXISTENCE OF THE FILE, AND CHECKS THE FIRST
;;; WORD TO SEE WHETHER IT IS AN ASCII OR FASL FILE.
;;; IF NO SECOND FILE NAME IS GIVEN, "FASL" IS TRIED FIRST,
;;; AND THEN ">" IF NO FASL FILE EXISTS.
;;; IF A FASL FILE, IT GIVES THE FILE NAMES TO FASLOAD.
;;; IF AN ASCII FILE, IT IS OPENED, (INFILE ↑Q, *, +, -, INSTACK)
;;; BOUND TO (<THE FILE>, T, *, +, -, NIL), AND A READ-EVAL
;;; LOOP PERFORMED UNTIL END OF FILE OCCURS LEAVING INSTACK=NIL
;;; AND INFILE=T.
LOAD: JUMPE A,CPOPJ ;IF GIVEN NIL AS ARG, RETURN NIL
PUSHJ P,FIL6BT ;SUBR 1
20$ MOVE F,-L.6EXT-L.6VRS+1(FXP)
20% MOVS F,(FXP)
PUSHJ P,DMRGF ;DMRGF SAVES F
LOCKI
20% CAIE F,(SIXBIT \*\)
JUMPN F,LOAD3
IFN ITS+D10, MOVE TT,[SIXBIT \FASL\]
IT$ MOVEM TT,-1(FXP)
10$ HLLZM TT,-1(FXP)
20$ MOVE TT,[ASCII \FASL\]
20$ MOVEM TT,-L.6EXT-L.6VRS+1(FXP)
JSP T,FASLP1
JRST LOAD1 ;FILE NOT FOUND
JRST LOAD2 ;FASL FILE
LOAD5: UNLOCKI ;EXPR FILE FOUND
PUSHJ P,6BTNML
PUSH P,[LOAD6]
PUSH P,A
MOVNI T,1
JRST $EOPEN ;OPEN AS A FILE OBJECT
LOAD6: HRRZ B,VIPLUS ;WE WANT +, -, * TO WORK AS FOR TOP LEVEL,
HRRZ C,V. ; BUT NOT SCREW THE OUTSIDE WORLD
HRRZ AR1,VIDIFFERENCE
MOVEI AR2A,TRUTH
JSP T,SPECBIND
0 A,VINFILE
0 B,VIPLUS
0 C,V.
0 AR1,VIDIFFERENCE
0 AR2A,TAPRED
VINSTACK
JRST LOAD7A
LOAD7: PUSHJ P,TLEVAL ;USE THE EVAL PART OF THE TOP LEVEL
HRRZM A,V.
LOAD7A:
REPEAT 2, PUSH P,[LOAD8] ;ONCE FOR RANDOM EOF VALUE
MOVNI T,1
JRST IREAD1
LOAD8: CAIE A,LOAD8
JRST LOAD7
HRRZ B,VINFILE
SKIPN VINSTACK
CAIE B,TRUTH
JRST LOAD7A
PUSHJ P,UNBIND
JRST TRUE
LOAD1:
IT$ MOVSI TT,(SIXBIT \>\) ;OTHERWISE TRY ">"
SA$ MOVSI TT,(SIXBIT \←←←\)
SA% 10$ MOVSI TT,(SIXBIT \LSP\) ;FOR D10, "LSP"
20% MOVEM TT,-1(FXP)
20$ MOVSI TT,[ASCIZ \MACLISP\]
20$ HRRI TT,-L.6EXT-L.6VRS(FXP) ;REMEMBER ADJUSTMENT FOR LOCKI WORD
20$ BLT TT,-L.6EXT-L.6VRS+1(FXP)
MOVEM TT,-1(FXP)
LOAD3: MOVEI A,QLOAD
JSP T,FASLP1
JRST LOAD4 ;LOSE COMPLETELY
JRST LOAD2 ;FASL FILE
JRST LOAD5 ;EXPR CODE
LOAD2: UNLOCKI ;FASL FILE - GO FASLOAD IT
PUSHJ P,6BTNML
HRRZ B,VDEFAULTF
JSP T,SPECBIND
0 B,VDEFAULTF ;DON'T LET FASLOAD CLOBBER DEFAULTF
PUSHJ P,FASLOAD
JRST UNBIND
LOAD4: IOJRST 0,.+1
PUSH P,A
UNLOCKI
PUSHJ P,6BTNML ;LOSEY LOSEY
PUSHJ P,NCONS
POP P,B
JRST XCIOL
;;; (FASLP <FILE>) TELLS WHETHER THE FILE IS A FASL FILE.
;;; ERROR IF FILE DOES NOT EXIST.
$FASLP: PUSHJ P,FIL6BT
PUSHJ P,DMRGF
MOVEI A,Q$FASLP
LOCKI
JSP T,FASLP1
JRST LOAD4
SKIPA A,[TRUTH]
MOVEI A,NIL
UNLOCKI
SUB FXP,R70+4
POPJ P,
;;; ROUTINE TO TEST A FILE FOR FASL-NESS.
;;; JSP T,FASLP1
;;; JRST NOTFOUND ;FILE NOT FOUND, OR OTHER ERROR
;;; JRST FASL ;FILE IS A FASL FILE
;;; ... ;FILE IS NOT A FASL FILE
;;; FXP MUST HOLD THE "SIXBIT" FILE NAMES, WITH A LOCKI WORD ABOVE THEM.
;;; USER INTERRUPTS MUST BE LOCKED OUT.
FASLP1:
IFN ITS,[
.CALL FASLP9 ;OPEN FILE ON TEMP CHANNEL
JRST (T)
.CALL FASLP8 ;RESTORE REFERENCE DATE
JFCL ; (ONLY WORKS FOR DISK CHANNELS - IGNORE FAILURE)
HRROI D,TT
.IOT TMPC,D ;READ FIRST WORD
.CLOSE TMPC,
JUMPL D,2(T) ;NOT A FASL FILE IF ZERO-LENGTH
] ;END OF IFN ITS
IFN D10,[
PUSH P,T
MOVEI T,.IODMP
MOVE TT,-4(FXP)
SETZ D,
OPEN TMPC,T ;OPEN TEMP CHANNEL TO FILE
POPJ P,
MOVE T,-2(FXP) ;FILE NAME
HLLZ TT,-1(FXP) ;EXTENSION
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
MOVE R,-3(FXP) ;PPN
LOOKUP TMPC,T ;LOOK UP FILE NAMES
JRST FASLP2
SETZB TT,R
PUSH FXP,NIL ;USE A WORD ON FXP AS D10 CAN'T DO I/O TO AC'S
HRROI D,-1(FXP) ;D AND R ARE THE DUMP MODE COMMAND LIST
INPUT TMPC,D ;GET FIRST WORD OF FILE
SA% CLOSE TMPC,CL.ACS ;DON'T UPDATE ACCESS DATE
RELEASE TMPC,
POP FXP,TT ;GET THE WORD READ FROM THE FILE
POP P,T
SA$ WARN [RESTORE REF DATE FOR SAIL PROBEF?]
;FALLS THROUGH
] ;END OF IFN D10
IFN D20,[
PUSH FLP,(FXP) ;SAVE THE LOCKI WORD, BUT OFF FXP
POPI FXP,1
PUSH P,T
PUSHJ P,X6BTNS ;GET NAMESTRING IN PNBUF
PUSH FXP,(FLP) ;PUT LOCKI WORD BACK IN ITS PLACE
POPI FLP,1
MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT) .SEE .GJDEF
MOVE 2,PNBP
GTJFN ;GET A JFN FOR THE FILE NAME
POPJ P,
MOVE 2,[440000,,OF%RD+OF%PDT] .SEE OF%BSZ OF%MOD
SETZ TT,
OPENF ;OPEN FILE, PRESERVING ACCESS DATE
JRST FASLP2
BIN ;GET ONE 36.-BIT BYTE
MOVE TT,2
CLOSF ;CLOSE THE FILE
JFCL ;IGNORE ERROR RETURN
SKIPA ;JFN HAS BEEN RELEASED BY THE CLOSE
FASLP2: RLJFN ;RELEASE THE JFN
JFCL
SETZB 1,2 ;CLEAR OUT CRUD IN 1 AND 2
POP P,T
] ;END OF IFN D20
TRZ TT,1
CAMN TT,[SIXBIT \*FASL*\]
JRST 1(T) ;FASL FILE IF FIRST WORD CHECKS
JRST 2(T)
IFN ITS,[
FASLP8: SETZ
SIXBIT \RESRDT\ ;RESTORE REFERENCE DATE
401000,,TMPC ;CHANNEL #
FASLP9: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,6 ;IMAGE BLOCK INPUT
1000,,TMPC ;CHANNEL NUMBER
,,-4(FXP) ;DEVICE NAME
,,-2(FXP) ;FILE NAME 1
,,-1(FXP) ;FILE NAME 2
400000,,-3(FXP) ;SNAME
] ;END OF IFN ITS
IFN D10,[
FASLP2: RELEASE TMPC,
POPJ P,
]
;;; (DEFUN INCLUDE FEXPR (X)
;;; ((LAMBDA (F)
;;; (EOFFN F '+INTERNAL-INCLUDE-EOFFN)
;;; (INPUSH F))
;;; (OPEN (CAR X))))
INCLUDE:
HLRZ A,(A) ;FSUBR
PUSH P,[INCLU1]
PUSH P,A
MOVNI T,1
JRST $EOPEN
INCLU1: MOVEI TT,FI.EOF
MOVEI B,QINCEOF
MOVEM B,@TTSAR(A)
JRST INPUSH
INCEOF==:FALSE ;INCLUDE'S EOF FUNCTION - SUBR 2
;
SUBTTL OPEN FUNCTION (INCLUDING SAIL EOPEN)
;;; (OPEN <FILE> <MODELIST>) OPENS A FILE AND RETURNS A
;;; CORRESPONDING FILE OBJECT. IT IS ACTUALLY AN LSUBR
;;; OF ZERO TO TWO ARGUMENTS. THE <FILE> DEFAULTS TO THE
;;; CURRENT DEFAULT FILE NAMES. THE <MODELIST> DEFAULTS
;;; TO NIL.
;;; IF <FILE> IS A NAMELIST OR NAMESTRING, A NEW FILE ARRAY
;;; IS CREATED. IF <FILE> IS A FILE ARRAY ALREADY, IT IS
;;; CLOSED AND RE-OPENED IN THE SPECIFIED MODE; ITS FORMER
;;; MODES SERVE AS THE DEFAULTS FOR THE <MODELIST>.
;;; THE <MODELIST> DETERMINES A LARGE NUMBER OF ATTRIBUTES
;;; FOR OPENING THE FILE. FOR EACH ATTRIBUTE THERE ARE
;;; TWO OR MORE MUTUALLY EXCLUSIVE VALUES WHICH MAY BE
;;; SPECIFIED AS FOLLOWS. VALUES MARKED BY A * ARE THOSE
;;; USED AS DEFAULTS WHEN THE <FILE> IS A NAMELIST OR
;;; NAMESTRING. IF THE <MODELIST> IS AN ATOM, IT IS THE
;;; SAME AS SPECIFYING THE LIST OF THAT ONE ATOM.
;;; DIRECTION:
;;; * IN INPUT FILE
;;; * READ SAME AS "IN"
;;; OUT OUTPUT FILE
;;; PRINT SAME AS "OUT"
;;; APPEND OUTPUT, APPENDED TO EXISTING FILE
;;; DATA MODE:
;;; * ASCII FILE IS A STREAM OF ASCII CHARACTERS.
;;; SYSTEM-DEPENDENT TRANSFORMATIONS MAY
;;; OCCUR, SUCH AS SUPPLYING LF AFTER CR,
;;; OR BEING CAREFUL WITH OUTPUT OF ↑P,
;;; OR MULTICS ESCAPE CONVENTIONS.
;;; FIXNUM FILE IS A STREAM OF FIXNUMS. THIS
;;; IS FOR DEALING WITH FILES THOUGHT OF
;;; AS "BINARY" RATHER THAN "CHARACTER".
;;; FOR TTY'S, THIS IS INTERPRETED AS
;;; "MORE-THAN-ASCII" OR "FULL CHARACTER
;;; SET" MODE, WHICH READS 9 BITS AT SAIL
;;; AND 12. ON ITS.
;;; IMAGE FILE IS A STREAM OF ASCII CHARACTERS.
;;; ABSOLUTELY NO TRANSFORMATIONS ARE MADE.
;;; DEVICE TYPE:
;;; * DSK STANDARD KIND OF FILE.
;;; CLA (ITS ONLY) LIKE DSK, BUT REQUIRES BLOCK MODE,
;;; AND GOBBLES THE FIRST TWO WORDS, INSTALLING
;;; THEM IN THE TRUENAME. USEFUL PRIMARILY FOR
;;; A CLI-MESSAGE INTERRUPT FUNCTION.
;;; TTY CONSOLE. IN PARTICULAR, ONLY TTY INPUT
;;; FILES HAVE INTERRUPT CHARACTER FUNCTIONS
;;; ASSOCIATED WITH THEM.
;;; BUFFERING MODE:
;;; * BLOCK DATA IS BUFFERED.
;;; SINGLE DATA IS UNBUFFERED.
;;; PRINTING AREA:
;;; ECHO (ITS ONLY) OPEN TTY IN ECHO AREA
;;; SOME OF THESE VALUES ARE OF COURSE SYSTEM-DEPENDENT.
;;; YOUR LOCAL LISP SYSTEM WILL ATTEMPT TO DO THE RIGHT THING,
;;; HOWEVER, IN ANY CASE.
;;; IF THE OPTIONS LIST IS INVALID IN ANY WAY, OPEN MAY EITHER
;;; GIVE A WRNG-TYPE-ARGS ERROR, OR BLITHELY ASSUME A CORRECTED
;;; VALUE FOR AN ATTRIBUTE. IN GENERAL, ERRORS SHOULD OCCUR
;;; ONLY FOR TRULY CONFLICTING SPECIFICATIONS. ON THE OTHER
;;; HAND, SPECIFYING BLOCK MODE FOR A DEVICE THAT THE SYSTEM
;;; WANTS TO HANDLE ONLY IN CHARACTER MODE WILL JUST GO AHEAD
;;; AND USE CHARACTER MODE. IN GENERAL, ONE SHOULD USE
;;; (STATUS FILEMODE) TO SEE HOW THE FILE WAS ACTUALLY OPENED.
;$OPEN $OPNNS OPEN0J OPEN1A OPEN1C OPN1F1 OPEN1F OPEN1G OPEN1K OPEN1H OPEN1Z
SA% $EOPEN:
$OPEN: MOVEI D,Q$OPEN ;LSUBR (0 . 2)
CAMGE T,XC-2
JRST WNALOSE
SETZB A,B ;BOTH ARGUMENTS DEFAULT TO NIL
CAMN T,XC-2
POP P,B
SKIPE T
POP P,A
IFN SFA,[
JSP TT,AFOSP ;WERE WE HANDED AN SFA AS FIRST ARG?
JFCL
JRST $OPNNS ;NOPE, CONTINUE AS USUAL
MOVEI C,(B) ;ARG TO SFA IS THE LIST GIVEN TO OPEN
MOVEI B,Q$OPEN ;OPERATION
JRST ISTCSH ;SHORT INTERNAL CALL
$OPNNS: ] ;END IFN SFA
;THE TWO ARGUMENTS ARE NOW IN A AND B.
;WE NOW PARSE THE OPTIONS LIST. F WILL HOLD OPTION VALUES,
; AND D WILL INDICATE WHICH WERE SPECIFIED EXPLICITLY BY THE USER.
OPEN0J: PUSH P,T ;SAVE NUMBER OF ARGS ON P (NOT FXP!)
SETZB D,F
JSP TT,AFILEP ;IS THE FIRST ARGUMENT A FILE OBJECT?
JRST OPEN1A
MOVEI TT,F.MODE
MOVE F,@TTSAR(A) ;IF SO, USE ITS MODE AS THE DEFAULTS
IT$ SKIPE B ;MAKE CHUCK RICH HAPPY - DON'T LET "ECHO" CARRY
IT$ TLZ F,FBT.EC+FBT.CP+FBT.SC ; OVER IF A NON-NULL OPTIONS LIST WAS GIVEN
OPEN1A: JUMPE B,OPEN1Y ;JUMP OUT IF NO OPTIONS SUPPLIED
MOVEI C,(B)
MOVEI TT,(B)
LSH TT,-SEGLOG
SKIPG ST(TT)
JRST OPEN1C
MOVSI AR2A,(B) ;IF A SINGLE, ATOMIC OPTION WAS GIVEN, AR2A
MOVEI C,AR2A ; IS A FAKE CONS CELL SO IT LOOKS LIKE A LIST
OPEN1C: JUMPE C,OPEN1L ;JUMP OUT IF LAST OPTION PROCESSED
HLRZ AR1,(C)
OPN1F1: JUMPE AR1,OPEN1G ;IGNORE NIL AS A KEYWORD
MOVSI TT,-LOPMDS
OPEN1F: HRRZ R,OPMDS(TT) ;COMPARE GIVEN OPTION AGAINST VALID ONES
CAIN AR1,(R)
JRST OPEN1K ;JUMP ON MATCH
AOBJN TT,OPEN1F
EXCH A,AR1 ;ERRONEOUS KEYWORD INTO AR1
WTA [IS ILLEGAL KEYWORD - OPEN!]
EXCH A,AR1
OPEN1G: HRRZ C,(C) ;CDR DOWN LIST UNTIL ALL DONE
JRST OPEN1C
OPEN1K: TDNN D,OPMDS(TT) ;SEE IF THERE IS A CONFLICT
JRST OPEN1Z
OPEN1H: EXCH A,B
WTA [ILLEGAL OPTIONS LIST - OPEN!]
EXCH A,B
JRST OPEN0J
OPEN1Z: HLRZ R,OPMDS(TT)
TLO D,(R)
TLZ F,(R)
TRZ F,(R)
IOR F,OPBITS(TT)
JRST OPEN1G
;OPMDS LOPMDS OPBITS
;;; LEFT HALF IS SET OF MODE BITS WHICH THE OPTION IN THE RIGHT
;;; HALF WILL CONFLICT WITH IF ANY ONE ELSE SELECTS THEM.
OPMDS: FBT.AP+1,,Q$IN
FBT.AP+1,,QOREAD
FBT.AP+1,,Q$OUT
FBT.AP+1,,Q%PRINT
FBT.AP+1,,QAPPEND
000014,,Q$ASCII
000014,,QFIXNUM
000014,,QIMAGE
000002,,QDSK
IT$ FBT.CA+2,,QCLA
000002,,QTTY
FBT.CM,,QBLOCK
FBT.CM,,QSINGLE
0,,QNODEFAULT
IT$ FBT.EC,,QECHO
IT$ FBT.SC,,QSCROLL
LOPMDS==.-OPMDS
;;; MODE BITS ACTUALLY TO BE SET FOR AN OPTION IN THE OPMDS TABLE.
OPBITS: 0 ;IN
0 ;READ
1 ;OUT
1 ;PRINT
FBT.AP,,1 ;APPEND
0 ;ASCII
4 ;FIXNUM
10 ;IMAGE
0 ;DSK
IT$ FBT.CA,,0 ;CLA
2 ;TTY
0 ;BLOCK
FBT.CM,, ;SINGLE
FBT.ND,, ;NODEFAULT
IT$ FBT.EC,, ;ECHO
IT$ FBT.SC,, ;SCROLL
TBLCHK OPBITS,LOPMDS
;OPEN1L OPEN1Y OPEN1S OPEN1M OPEN1N OPEN1P OPEN1R OPEN1Q
;STATE OF THE WORLD:
; FIRST ARG TO OPEN IN A
; SECOND ARG IN B
; D CONTAINS BITS FOR ACTUALLY SPECIFIED OPTIONS IN LEFT HALF
; F CONTAINS BITS FOR OPTIONS
.SEE FBT.CM ;AND FRIENDS
; 1.4-1.3 0 => ASCII, 1 => FIXNUM, 2 => IMAGE
; 1.2 0 => DSK, 1 => TTY
; 1.1 0 => IN, 1 => OUT
; BITS 1.4-1.1 ARE USED TO INDEX VARIOUS TABLES LATER
; ACTUAL NUMBER OF ARGS ON P
;WE NOW EMBARK ON DEFAULTING AND MAKING CONSISTENT THE VARIOUS MODES
OPEN1L: TLNE D,FBT.CM ;SKIP IF SINGLE VS. BLOCK WAS UNSPECIFIED
JRST OPEN1Y
TRNE F,2 ;SKIP UNLESS TTY
TLO F,FBT.CM ;FOR TTY, DEFAULT TO SINGLE, NOT BLOCK, MODE
OPEN1Y:
IT$ TRC F,3
IT$ TRCE F,3
IT$ TLZ F,FBT.EC+FBT.SC ;ECHO AND SCROLL MEANINGFUL ONLY FOR TTY OUTPUT
TRNN F,2 ;SKIP IF TTY
JRST OPEN1S
TLZ F,FBT.AP ;CAN'T APPEND TO A TTY
TRNN F,1
TLO F,FBT.CM ;CAN'T DO BLOCK TTY INPUT
TRNE F,4 ;FIXNUM TTY I/O USES FULL CHAR SET
TLO F,FBT.FU
;NOW WORRY ABOUT FILE NAMES AND ALLOCATING A FILE OBJECT
OPEN1S: PUSH P,A
PUSH P,B
PUSH FXP,F
CAIE A,TRUTH ;T MEANS TTY FILE ARRAY...
JRST OPEN1M
TRNN F,1
SKIPA A,V%TYI ;TTY INPUT IF MODE BITS SAY INPUT
HRRZ A,V%TYO ; AND OUTPUT OTHERWISE
OPEN1M: PUSH P,A
PUSHJ P,FIL6BT ;GET FILE NAME SPECS
MOVE F,-L.F6BT(FXP) ;GET MODE BITS
TLZN F,FBT.ND ;MERGE WITH DEFAULT NAMES?
PUSHJ P,DMRGF ;MERGE IN DEFAULT NAMES (SAVES F)
HRLZI F,FBT.ND
ANDCAM F,-L.F6BT(FXP) ;TURN OFF FBT.ND BIT IN SAVED FLAGS
MOVE A,(P) ;GET (POSSIBLY MUNGED FOR T) FIRST ARG
JSP TT,AFILEP ;SKIP IF WE GOT A REAL LIVE SAR
JRST OPEN1N
PUSHJ P,ICLOSE ;CLOSE IT IF NECESSARY
20$ WARN [SHOULD WE RELEASE THE JFN AT THIS POINT?]
MOVE A,(P)
MOVE D,-3(P) ;IF ONLY ONE ARG TO OPEN, AND
AOJE D,OPEN1Q ; THAT A SAR, RE-USE THE ARRAY
MOVE F,-L.F6BT(FXP)
MOVEI TT,F.MODE
XOR F,@TTSAR(A)
TDNE F,[FBT.CM,,17]
JRST OPEN1P
PUSHJ P,OPNCLR ;IF TWO ARGS, BUT SAME MODE,
JRST OPEN1Q ; CLEAR ARRAY, THAN RE-USE
;WE MUST ALLOCATE A FRESH ARRAY
OPEN1N: MOVSI A,-1 ;ARRANGE TO GET A FRESH SAR
;WE HAVE A SAR, BUT MUST ALLOCATE A NEW ARRAY BODY
OPEN1P: MOVE F,-L.F6BT(FXP) ;GET MODE BITS AGAIN
;DETERMINE SIZE OF NEW ARRAY
IFN ITS+D20,[
HLRZ TT,OPEN9A(F) ;FOR ITS AND D20, DESIRABLE SIZES ARE IN A TABLE
SKIPGE F .SEE FBT.CM
HRRZ TT,OPEN9A(F)
] ;END OF IFN ITS+D20
IFN D10,[
;FOR D10, WE MUST ASK THE OPERATING SYSTEM FOR THE PROPER BUFFER SIZE
MOVE TT,-3(FXP) ;GET DEVICE NAME
CAME TT,[SIXBIT \TTY\]
TRZ F,2 ;? NOT A TTY UNLESS IT IS *THE* TTY
TRNN F,2
TLZA F,FBT.CM ;ONLY THE TTY CAN BE SINGLE MODE,
TLO F,FBT.CM ; AND THE TTY MUST BE SINGLE MODE!
SA$ TRNE F,2 ;FOR SAIL, *THE* TTY SHOULD DEFAULT TO LINEMODE
SA$ TLO F,FBT.LN
MOVEM F,-4(FXP) ;SAVE BACK MODE BITS
PUSHN FXP,1 ;PUSH A SLOT FOR BUFFER SIZE DATA
JUMPL F,OPEN1R .SEE FBT.CM
IFE SAIL,[
HLRZ T,OPEN9C(F) ;GET DESIRED I/O MODE
MOVEI D,T
DEVSIZ D, ;ON SUCCESS, GET <NUMBER OF BUFFERS,,BUFFER SIZE>
SETO D,
SKIPG D
MOVE D,[2,,3+LIOBUF] ;ON FAILURE, USE 2 BUFFERS AT LIOBFS WORDS APIECE
HLRZ TT,D
CAIGE TT,NIOBFS
] ;END IFE SAIL
IFN SAIL,[
MOVE D,TT ;DEVICE NAME IN D
BUFLEN D, ;GET BUFFER SIZE
SKIPN D ;NO WAY!! (BUT BETTER CHECK ANYWAY)
MOVEI D,LIOBUF+1 ;DEFAULT
ADDI D,2 ;WE NEED ACTUAL SIZE OF BUFFER, NOT SIZE-2
] ;END IFN SAIL
HRLI D,NIOBFS ;HOWEVER, WE MUST USE AT LEAST NIOBFS BUFFERS
MOVEM D,(FXP) ;SAVE THIS DATA
HLRZ TT,D
IMULI D,(TT) ;GET TOTAL SPACE OCCUPIED BY BUFFERS
HLRZ TT,OPEN9A(F)
ADDI TT,(D) ;ADD TO SIZE OF REST OF FILE ARRAY
CAIA
OPEN1R: HRRZ TT,OPEN9A(F) ;FOR CHARACTER MODE, TABLE HAS TOTAL ARRAY SIZE
] ;END OF IFN D10
PUSHJ P,MKLSAR ;MAKE AN ARRAY - SIZE IN TT, SAR (IF ANY) IN A
10$ POP FXP,D
OPEN1Q: LOCKI ;LOCK OUT USER INTERRUPTS
;FALLS THROUGH
;OPEN1T
;FALLS IN
;STATE OF THE WORLD:
; USER INTERRUPTS LOCKED OUT
; SAR FOR FILE ARRAY IN A
; FOR D10, BUFFER SIZE INFORMATION IN D
; P: FIRST ARGUMENT, OR TTY SAR IF ARGUMENT WAS T
; SECOND ARGUMENT
; FIRST ARGUMENT
; (NEGATIVE OF) ACTUAL NUMBER OF ARGS
; FXP: LOCKI WORD
; FILE NAMES IN "SIXBIT" FORMAT (L.F6BT WORDS)
; MODE BITS
MOVSI TT,TTS.IM+TTS.BN+TTS.TY+TTS.IO
ANDCAM TT,TTSAR(A)
MOVE F,-1-L.F6BT(FXP) ;GET MODE BITS
HLLZ TT,OPEN9B(F)
IORB TT,TTSAR(A) ;SET CLOSED BIT AND FILE TYPE BITS
IFN D10,[
JUMPL F,OPEN1T .SEE FBT.CM
HLRZM D,FB.NBF(TT) ;STORE NUMBER OF BUFFERS
SUBI D,3
HRRZM D,FB.BWS(TT) ;STORE BUFFER DATA SIZE IN WORDS
OPEN1T:
] ;END OF IFN D10
MOVSI TT,AS.FIL
IORB TT,ASAR(A) ;NOW CAN TURN ON FILE ARRAY BIT
MOVEI T,-F.GC
HRLM T,-1(TT) ;SET UP GC AOBJN POINTER
MOVEM A,(P) ;SAVE THE FILE ARRAY SAR
PUSHJ P,ALCHAN ;ALLOCATE A CHANNEL
JRST OPNALZ ;LOSE IF NO FREE CHANNELS
MOVE TT,TTSAR(A)
HRRZM F,F.CHAN(TT) ;SAVE THE CHANNEL NUMBER IN THE FILE OBJECT
POP FXP,T ;BEWARE THE LOCKI WORD!
MOVEI D,F.DEV(TT)
HRLI D,-L.F6BT+1(FXP)
BLT D,F.DEV+L.F6BT-1(TT) ;COPY FILE NAMES INTO FILE OBJECT
POPI FXP,L.F6BT ;FLUSH THEM FROM THE STACK
EXCH T,(FXP) ;PUT LOCKI WORD ON STACK,
PUSH FXP,T ;WITH MODE BITS ABOVE IT
;FALLS THROUGH
;OPEN3 OPEN3C SOPEN3C OPEN3D OPN3D1 OPEN3E OPEN3F OPEN3M OPEN3N OPEN3D OPEN3E
;FALLS IN
;STATE OF THE WORLD:
; USER INTERRUPTS LOCKED OUT
; TTSAR OF FILE ARRAY IN TT
; P: SAR FOR FILE ARRAY
; SECOND ARGUMENT TO OPEN
; FIRST ARGUMENT
; -<# OF ACTUAL ARGS>
; FXP: MODE BITS (THEY OFFICIALLY LIVE HERE, NOT IN T)
; LOCKI WORD
;PDLS MUST STAY THIS WAY FROM NOW ON FOR THE SAKE OF IOJRST'S.
.SEE OPENLZ
OPEN3: MOVE T,(FXP) ;GET MODE BITS
;NOW WE ACTUALLY TRY TO OPEN THE FILE
IFN ITS,[
MOVE D,OPEN9C(T)
TLNE T,FBT.AP ;APPEND MODE =>
TRO D,100000 ; ITS WRITE-OVER MODE
TLNE T,FBT.EC ;MAYBE OPEN AN OUTPUT TTY
TRO D,%TJPP2 ; IN THE ECHO AREA (PIECE OF PAPER #2)
.CALL OPENUP
IOJRST 4,OPNLZ0
.CALL RCHST ;READ BACK THE REAL AND TRUE NAMES
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
JUMPL T,OPEN3M .SEE FBT.CM ;NEED NOT ALLOCATE A CHANNEL FOR *THE* TTY
MOVE F,F.CHAN(TT)
SA$ MOVEI R,(F)
MOVEI D,(F)
IMULI D,3
ADDI D,BFHD0 ;COMPUTE ADDRESS OF BUFFER HEADER
MOVEM D,FB.HED(TT) ;REMEMBER BUFFER HEADER ADR
SETZM (D) ;CLEAR BUFFER POINTER (TO FORCE NEW BUFFERS)
SETZM 1(D) ;CLEAR OLD BYTE POINTER
SETZM 2(D) ;CLEAR BYTE COUNT
TRNE T,1
MOVSS D ;IF OUTPUT BUFFER, PUT ADDRESS IN LEFT HALF
PUSH FXP,TT ;SAVE THE TTSAR
MOVE T,OPEN9C(T) ;GET THE I/O MODE FROM THE TABLE
MOVE TT,F.DEV(TT)
LSH F,27
IOR F,[OPEN 0,T]
XCT F ;OPEN THE FILE
JRST OPNAND
SA$ SHOWIT R,
MOVE R,-1(FXP) ;GET MODE BITS
XOR F,[<INBUF>#<OPEN>]
TRNE R,1
XOR F,[<OUTBUF>#<INBUF>]
MOVE TT,(FXP) ;GET BACK TTSAR
HRR F,FB.NBF(TT) ;GET NUMBER OF BUFFERS IN RH OF UUO
MOVEI TT,FB.BUF(TT)
EXCH TT,.JBFF ;.JBFF IS THE ORIGIN FOR ALLOCATING BUFFERS
XCT F ;TELL THE MONITOR TO ALLOCATE BUFFERS
MOVEM TT,.JBFF ;RESTORE OLD VALUE OF .JBFF
AND F,[0 17,] ;ISOLATE CHANNEL NUMBER AGAIN
IOR F,[LOOKUP 0,T]
MOVE TT,(FXP) ;GET TTSAR BACK IN TT
TRNE R,1 ;WE NEED TO PERFORM A LOOKUP FOR
TLNE R,FBT.AP ; EITHER IN OR APPEND MODE
CAIA
JRST OPEN3C
MOVE T,F.FN1(TT)
MOVE R,F.PPN(TT)
HLLZ TT,F.FN2(TT)
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
XCT F ;PERFORM THE LOOKUP
IOJRST 4,OPNLZ1 ;LOSEY LOSEY
OPEN3C: MOVE D,-1(FXP) ;GET MODE BITS
TRNN D,1 ;NEED TO PERFORM AN ENTER FOR
JRST OPEN3D ; EITHER OUT OR APPEND MODE
TLNN D,FBT.AP ;APPEND MODE MEANS READ-ALTER, DO LOOKUP FIRST
XOR F,[<ENTER 0,T>#<LOOKUP 0,T>]
MOVE TT,(FXP) ;GET TTSAR
MOVE T,F.FN1(TT)
MOVE R,F.PPN(TT)
HLLZ TT,F.FN2(TT)
SA$ CAMN TT,[SIXBIT \←←←\]
SA$ SETZ TT,
SETZ D,
XCT F ;PERFORM THE ENTER (OR POSSIBLY LOOKUP FOR SAIL)
IOJRST 4,OPNLZ1 ;LOSEY LOSEY
IFN SAIL,[
MOVE D,-1(FXP) ;GET THOSE MODE BITS ONCE MORE
TLNN D,FBT.AP ;APPEND MODE MEANS READ-ALTER
JRST SOPEN3C ;NORMAL CASE SO JUMP AHEAD
XOR F,[<ENTER 0,T>#<LOOKUP 0,T>] ;MUMBLE
MOVE TT,(FXP) ;GET TTSAR
MOVE T,F.FN1(TT)
PUSH FXP,R ;SAVE SIZE INFO
MOVE R,F.PPN(TT)
HLLZ TT,F.FN2(TT)
CAMN TT,[SIXBIT \←←←\]
SETZ TT,
SETZ D,
XCT F ;PERFORM THE ENTER
IOJRST 4,OPNLZS ;LOSEY LOSEY
XOR F,[<OUTPUT 0,>#<ENTER 0,T>]
XCT F ;SET UP BUFFER HEADER BYTE POINTER AND COUNT
XOR F,[<UGETF 0,T>#<OUTPUT 0,>] ;NOW THE UGETF, HEH, HEH
XCT F
POP FXP,R ;RESTORE SIZE INFO
JRST OPEN3D ;GO, GO, GO
SOPEN3C:
] ;END IFN SAIL
XOR F,[<OUT 0,>#<ENTER 0,T>]
XCT F ;SET UP BUFFER HEADER BYTE POINTER AND COUNT
;AS A RESULT OF THE LOOKUP OR ENTER, THE SIZE INFORMATION IS IN R
OPEN3D: MOVE D,TT
POP FXP,TT
HLLZM D,F.RFN2(TT) ;SAVE AWAY THE REAL, TRUE FILE NAMES
MOVEM T,F.RFN1(TT)
MOVE D,F.CHAN(TT) ;GET CHANNEL FOR DEVCHR
DEVCHR D, ;DEVICE CHRACTERISTICS
TLNE D,(DV.DIR) ;IF NON-DIRECTORY ZERO TRUENAMES
JRST OPN3D1
SETZM F.RFN2(TT)
SETZM F.RFN1(TT)
OPN3D1: MOVE D,F.CHAN(TT)
SA% DEVNAM D, ;GET REAL NAME OF DEVICE
SA$ PNAME D,
MOVE D,F.DEV(TT) ;USE GIVEN DEVICE NAME ON FAILURE
MOVEM D,F.RDEV(TT)
MOVE F,F.CHAN(TT) ;TRY TO DETERMINE REAL PPN
SA% DEVPPN F,
SA% CAIA
SA% JRST OPEN3F
SA% TRZ D,770000
CAMN D,[SIXBIT \SYS\]
JRST OPEN3E
SA% GETPPN F, ;IF ALL ELSE FAILS, ASSUME YOUR OWN PPN
SA% JFCL ;CAN'T REALLY FAIL - THIS JFCL IS FOR ULTRA SAFETY
SA$ SKIPE F,F.PPN(TT) ;IF PPN WAS SPECIFIED
SA$ JRST OPEN3F ;USE IT AS TRUE PPN
SA$ SETZ F,
SA$ DSKPPN F, ;FOR SAIL, USE THE DSKPPN (ALIAS)
JRST OPEN3F
OPEN3E:
SA% MOVE F,[%LDSYS]
SA% GETTAB R,
SA% MOVE F,R70+1 ;ASSUME SYS: IS 1,,1 IF GETTAB FAILS
SA$ MOVE F,[SIXBIT \ 1 3\] ;IT'S [1,3] ON SAIL
OPEN3F: MOVEM F,F.RPPN(TT)
JRST OPEN3N
OPEN3M: MOVE D,F.DEV(TT) ;FOR THE TTY, JUST COPY THE DEVICE NAME
MOVEM D,F.RDEV(TT)
OPEN3N:
] ;END OF IFN D10
IFN D20,[
MOVE T,F.DEV(TT)
CAME T,[ASCII \TTY\] ;SKIP IF OPENING *THE* TTY
JRST OPEN3D
MOVEI 1,.PRIIN ;CONSIDER USING THE PRIMARY JFN
TLNE TT,TTS.IO ; OF THE APPROPRIATE DIRECTION
MOVEI 1,.PRIOU
; GTSTS ;MAKE SURE IT IS OPEN
; JUMPGE 2,OPEN3D .SEE GS%OPN
; MOVSI D,(GS%RDF+GS%NAM) ;MAKE SURE IT CAN DO THE KIND OF I/O WE WANT
; TLNE TT,TTS.IO
; MOVSI D,(GS%WRF+GS%NAM)
; TDC 2,D
; TDCN 2,D
MOVE T,(FXP) ;RESTORE FLAG BITS
JRST OPEN3E
;HERE TO ALLOCATE A FRESH JFN AND OPEN THE FILE
OPEN3D: PUSH FXP,TT ;SAVE THE TTSAR
MOVEI T,F.DEV(TT)
HRLI T,-L.F6BT
PUSH FXP,(T) ;COPY THE GIVEN DEVICE NAMES ONTO THE STACK
AOBJN T,.-1
PUSHJ P,6BTNSL ;CONVERT TO A NAMESTRING IN PNBUF
POP FXP,TT ;GET TTSAR
MOVE T,(FXP) ;RESTORE MODE BITS IN T
MOVSI 1,(GJ%ACC+GJ%SHT) .SEE .GJDEF
TRNE T,1
TLNE T,FBT.AP
TLOA 1,(GJ%OLD) ;FOR INPUT OR APPEND, WE WANT AN EXISTING FILE
TLO 1,(GJ%FOU+GJ%NEW) ;FOR OUTPUT, A NON-EXISTENT FILE
MOVE 2,PNBP
GTJFN ;GET A JFN
IOJRST 4,OPNLZ0
OPEN3E: MOVE 2,OPEN9C(T) ;GET OPEN MODE
TLNE T,FBT.AP ;APPEND MODE, SET APPEND, READ BITS, CLR WRITE
TRC 2,OF%APP+OF%WR+OF%RD
OPENF ;OPEN THE FILE
IOJRST 4,OPNLZR
HRRZM 1,F.JFN(TT) ;SAVE THE JFN IN THE FILE OBJECT
] ;END OF IFN D20
;FALLS THROUGH
;OPEN3G OPEN3P OPEN3K OPEN3J OPN3LA OPEN3L OPN3LB OPEN3Q OPEN3H OPEN3V OPEN3Z
;FALLS IN
10$ MOVE T,(FXP) ;FOR D10, FLAGS IN T MIGHT HAVE BEEN DESTROYED
JUMPL T,OPEN3G .SEE FBT.CM
MOVE D,OPEN9D(T) ;SOME INITIALIZATION FOR BLOCK MODE FILES
HRRZM D,FB.BYT(TT) ;SET UP BYTE SIZE
IFN ITS+D20,[
HRRI D,FB.BUF-1(TT)
MOVEM D,FB.IBP(TT) ;SET UP INITIAL BUFFER POINTER
HRRZ D,OPEN9B(T)
] ;END OF IFN ITS+D20
10$ MOVE D,FB.BWS(TT)
IMUL D,FB.BYT(TT) ;SET UP BUFFER LENGTH (IN BYTES)
MOVEM D,FB.BFL(TT)
OPEN3G: SETZM F.FPOS(TT) ;FILEPOS=0 (UNTIL FURTHER NOTICE)
;NOW DETERMINE THE SIZE OF THE FILE, AND SET THE ACCESS POINTER (IF APPLICABLE)
;MODE BITS ARE IN T, TTSAR IS IN TT; FOR D10, FILE SIZE INFO IN R;
;FOR D20, JFN IS IN 1
IFN ITS,[
SKIPL F.FLEN(TT) ;THIS WAS SET BY RCHST BEFORE; -1 = NOT RANDOM
JRST OPEN3P ; ACCESS
TLZ T,FBT.AP ;CAN'T APPEND IF NOT RANDOMLY ACCESSIBLE
JRST OPEN3Q
OPEN3P: HRLZI D,1 ;ASSUME 1000000 FOR FAILING FILLEN (USR DEVICE)
.CALL FILLEN ;DETERMINE LENGTH OF FILE
MOVEM D,F.FLEN(TT)
TLNN T,FBT.AP
JRST OPEN3Q
MOVE D,F.FLEN(TT) ;FOR APPEND MODE, SET THE ACCESS
MOVEM D,F.FPOS(TT) ; POINTER TO THE END OF THE FILE
.CALL ACCESS
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
JUMPL T,OPEN3Q ;DON'T DO ANY OF THIS FOR TTY
SETZM F.FPOS(TT)
MOVE D,F.CHAN(TT)
DEVCHR D,
TLNE D,(DV.DIR)
JRST OPEN3K
TLZ T,FBT.AP ;ASSUME A NON-DIRECTORY DEVICE CAN'T APPEND
SETOM F.FLEN(TT) ; OR PERFORM RANDOM ACCESS
JRST OPEN3Q
;FILE SIZE INFORMATION IS IN R
OPEN3K:
IFE SAIL,[
HLRE R,R ;FOR TOPS-10/CMU, THE LEFT HALF OF R
SKIPL R ; IS A WORD COUNT IF NEGATIVE AND A BLOCK COUNT
IMULI R,200 ; IF POSITIVE
MOVMS R
] ;END OF IFE SAIL
IFN SAIL,[
MOVSS R ;SAIL JUST HAS SWAPPED NAGATIVE WORD COUNT
MOVNS R
] ;END OF IFN SAIL
IMUL R,FB.BYT(TT)
MOVEM R,F.FLEN(TT) ;STORE FILE LENGTH
TLNN T,FBT.AP
JRST OPEN3Q
MOVEM R,F.FPOS(TT) ;FOR APPEND MODE, SET POINTER TO EOF
MOVE F,F.CHAN(TT)
LSH F,27
SA% IOR F,[USETI 0,-1]
SA$ IOR F,[UGETF 0,R] ;THIS UUO WILL CLOBBER R
XCT F ;SET MONITOR'S POINTER TO EOF
IFN SAIL,[
;HACK UP ON SAIL'S RECORD OFFSET FEATURE
SETZM FB.ROF(TT) ;ASSUME NO RECORD OFFSET
TLNN D,200000 ;SKIP IF DSK/UDP (DEVCHR RESULT IS STILL IN D)
JRST OPEN3Q
MOVEM T,(FXP)
PUSH FXP,TT
XOR F,[<MTAPE 0,T>#<UGETF 0,R>]
MOVE T,[SIXBIT \GODMOD\]
MOVEI TT,20 ;SIXBIT \GODMOD\ ? 20 => GET RECORD OFFSET IN D
XCT F
POP FXP,TT
MOVE T,(FXP) ;CONVERT RECORD OFFSET TO A BYTE OFFSET
SUBI D,1 ; FROM THE LOGICAL ORIGIN OF THE FILE
IMUL D,FB.BFL(TT)
MOVNM D,FB.ROF(TT) ;STORE AS A NEGATIVE OFFSET IN BYTES
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
TLNN T,FBT.AP
JRST OPEN3L
SETO 2,
SFPTR ;SET FILE POSITION TO END FOR APPENDING
JRST OPEN3J
RFPTR ;READ BACK THE ACTUAL POSITION
IOJRST 4,OPENLZ
MOVEM 2,F.FLEN(TT)
MOVEM 2,F.FPOS(TT)
JRST OPEN3Q
OPEN3J: CAIE 1,SFPTX2 ;ILLEGAL TO RESET POINTER FOR THIS FILE?
IOJRST 4,OPENLZ
TLZ T,FBT.AP ;IF SO, JUST SAY WE CAN'T APPEND
SETOM F.FLEN(TT)
JRST OPEN3Q
OPN3LA: CAIE 1,DESX4 ;SIZEF LEGAL FOR THIS DEVICE?
IOJRST 4,OPENLZ ;NOPE, MUST BE SOME REAL ERROR
SETO 2, ;ELSE -1 IS LENGTH OF FILE
JRST OPN3LB
OPEN3L: SIZEF ;GET SIZE OF FILE
JRST OPN3LA
OPN3LB: MOVEM 2,F.FLEN(TT) ;SAVE AS LENGTH OF FILE
SETZM F.FPOS(TT) ;SET FILE POSITION TO ZERO
] ;END OF IFN D20
OPEN3Q: MOVEM T,(FXP) ;SAVE BACK POSSIBLY ALTERED MODE BITS
IFN ITS,[
TLNN T,FBT.CA ;FOR THE CLA DEVICE,
JRST OPEN3H ; GOBBLE DOWN THE FIRST TWO WORDS,
MOVEI T,F.RFN1(TT) ; WHICH ARE THE SIXBIT FOR THE
HRLI T,444400 ; UNAME-JNAME OF THE SENDER, AND
MOVEI D,2 ; USE THEM FOR THE TRUENAMES
.CALL SIOT ; OF THE FILE ARRAY
IOJRST 4,OPENLZ
MOVE T,(FXP) ;RESTORE MODE BITS
OPEN3H:
] ;END OF IFN ITS
TRNE T,1
JRST OPEN3V
HRRZ D,DEOFFN ;FOR INPUT, GET THE DEFAULT EOFFN
MOVEM D,FI.EOF(TT)
SETZM FI.BBC(TT)
; SETZM FI.BBF(TT) ;NOT IMPLEMENTED YET
JRST @OPEN3Z(T) ;DISPATCH TO APPROPRIATE PLACE
OPEN3V: HRRZ D,DENDPAGEFN ;FOR OUTPUT, GET THE DEFAULT ENDPAGEFN
MOVEM D,FO.EOP(TT)
MOVE D,DPAGEL ;DEFAULT PAGEL
MOVEM D,FO.PGL(TT)
MOVE D,DLINEL ;DEFAULT LINEL
MOVEM D,FO.LNL(TT)
SETZM FB.BVC(TT)
JRST @OPEN3Z(T) ;DISPATCH TO APPROPRIATE PLACE
OPEN3Z: OPNAI1 ;ASCII DSK INPUT
OPNAO1 ;ASCII DSK OUTPUT
OPNTI1 ;ASCII TTY INPUT
OPNTO1 ;ASCII TTY OUTPUT
OPNBI1 ;FIXNUM DSK INPUT
OPNBO1 ;FIXNUM DSK OUTPUT
OPNTI1 ;FIXNUM TTY INPUT
OPNTO1 ;FIXNUM TTY OUTPUT
OPNAI1 ;IMAGE DSK INPUT
OPNAO1 ;IMAGE DSK OUTPUT
OPNTI1 ;IMAGE TTY INPUT
OPNTO1 ;IMAGE TTY OUTPUT
;OPNBO1 OPNAO1 OPNBI1 OPNAI1 OPNA6 OPNTI1
OPNBO1:
OPNAO1: JUMPL T,OPNAT3 .SEE FBT.CM
MOVE D,FB.BFL(TT)
MOVEM D,FB.BVC(TT)
JRST OPNA6
OPNBI1:
OPNAI1: SETZM FB.BVC(TT)
OPNA6:
IFN ITS+D20,[
JUMPL T,OPNAT3 .SEE FBT.CM
MOVE D,FB.IBP(TT) ;INITIALIZE BUFFER BYTE POINTER
HRRZ R,OPEN9B(T)
TRNN T,1
ADDI D,(R) ;FOR AN INPUT BUFFER, FB.BP MUST BE ADJUSTED;
MOVEM D,FB.BP(TT) ; THE FIRST "EMPTY" BUFFER ISN'T A REAL ONE
MOVE D,FB.BFL(TT)
TRNN T,1
SETZ D,
MOVEM D,FB.CNT(TT)
] ;END OF IFN ITS+D20
JRST OPNAT3
OPNTI1:
10$ JUMPGE T,OPNAI1 .SEE FBT.CM ;ONLY *THE* TTY HAS THESE HACKS
SETZM TI.BFN(TT)
SETZM FT.CNS(TT)
IFN ITS,[
MOVE D,[STTYW1]
MOVEM D,TI.ST1(TT)
MOVE D,[STTYW2]
MOVEM D,TI.ST2(TT)
.CALL TTYGET
IOJRST 4,OPENLZ
;TURN OFF AUTO-INT, SUPER-IMAGE
TLZ F,%TSINT+%TSSII
TRNE T,10 ;TTY IMAGE INPUT =>
TLO F,%TSSII ; ITS SUPER-IMAGE INPUT
.CALL TTYSET
IOJRST 4,OPENLZ
] ;END OF IFN ITS
IFN SAIL,[
MOVEI D,[SACTW1 ? SACTW2 ? SACTW3 ? SACTW4]
HRLI D,TI.ST1(T)
SETACT D
MOVSS D
BLT D,TI.ST4(T)
SETO D,
GETLIN D
AOSN D ;IF NOT -1 THEN OK TO USE CHARACTERISTICS
SETZ D, ; ELSE CAN MAKE NO ASSUMPTIONS ABOUT TTY
TLNE D,460000 ;CHECK DISLIN, DMLIN, DDDLIN
TLOA T,FBT.FU
TLZ T,FBT.FU
MOVEM T,(FXP)
] ;END OF IFN SAIL
IFN D20,[
MOVE 2,CCOCW1
MOVEM 2,TI.ST1(TT)
MOVE 3,CCOCW1
MOVEM 3,TI.ST2(TT)
MOVE 1,F.JFN(TT)
SFCOC ;SET CCOC WORDS
MOVEI 2,TT%WKF+TT%WKN+TT%WKP+TT%ECO+<.TTASC←6> .SEE TT%DAM
TRNE T,10
XORI 2,<.TTBIN#.TTASC>←6 .SEE TT%DAM
SFMOD
] ;END OF IFN D20
JRST OPNAT3
;OPNTO1 OPNTO5
OPNTO1:
10$ JUMPGE T,OPNAO1 .SEE FBT.CM ;ONLT *THE* TTY HAS THESE HACKS!
SETZM FT.CNS(TT)
IFN ITS,[
.CALL CNSGET ;SET FO.RPL, FO.LNL, AND GET TTYOPT IN D
IOJRST 4,OPENLZ
MOVSI R,200000 ;INFINITE PAGEL INITIALLY
MOVEM R,FO.PGL(TT)
SOS FO.LNL(TT)
TLZ T,FBT.SA+FBT.CP+FBT.SE
TLNE D,%TOSA1 ;SKIP UNLESS WE HAVE SAIL CHARS
TLO T,FBT.SA ;SET SAIL BIT
TLNE D,%TOMVU ;IF WE CAN MOVE BACK, ASSUME WE
TLO T,FBT.CP ; ARE A DISPLAY TERMINAL (THIS IS OK ACCORDING
; TO ITSTTY)
TLNE D,%TOERS ;REMEMBER THE SELECTIVE ERASE BIT
TLO T,FBT.SE .SEE RUB1CH
MOVEM T,(FXP)
TLNN T,FBT.EC
JRST OPNTO5
.CALL SCML ;FOR ECHO AREA, SET NUMBER OF ECHO LINES TO 5
.LOSE 1400
OPNTO5: .CALL TTYGET
.LOSE 1400
TLNE F,%TSROL ;TURN ON SCROLL MODE IF TTY DEFAULTLY SCROLLS
TLO T,FBT.SC
MOVEM T,(FXP)
TLZ F,%TSFCO
TLNE T,FBT.FU
TLO F,%TSFCO
TLNE T,FBT.SC ;IF SCROLL MODE SET SCROLLING
TLO F,%TSROL
.CALL TTYSAC
.LOSE 1400
PUSHJ FXP,CLRO4 ;INITIALIZE LINENUM AND CHARPOS
JRST OPNA6
] ;END OF IFN ITS
IFN D10,[
MOVSI D,200000 ;INFINITY (???)
EXCH D,FO.PGL(TT)
MOVEM D,FO.RPL(TT)
SETZM AT.CHS(TT) ;SIGH
SETZM AT.LNN(TT)
IFE SAIL,[
SETO R,
GETLIN R, ;GET OUR TTY LINE NUMBER
TLZ R,-1
MOVEI D,.TOWID
MOVE F,[-2,,D]
TRMOP. F, ;TRY DETERMINING WIDTH OF TERMINAL
MOVEI D,111
SUBI D,1
MOVEM D,FO.LNL(TT)
JRST OPNA6
] ;END OF IFE SAIL
;IFN SAIL, FALLS THROUGH TO OPNAT3
] ;END OF IFN D10
IFN D20,[
MOVE 1,F.JFN(TT)
RFMOD ;READ JFN MODE WORD FOR TERMINAL
LDB D,[.BP TT%WID,1]
SUBI D,1
MOVEM D,FO.LNL(TT) ;SET LINEL
LDB D,[.BP TT%LEN,1]
MOVEM D,FO.RPL(TT)
TRNN 1,TT%PGM
MOVSI D,200000 ;FOR NON-PAGED MODE, USE INFINITY
MOVEM D,FO.PGL(TT)
PUSHJ FXP,CLRO4 ;INITIALIZE LINENUM AND CHARPOS
JRST OPNA6
] ;END OF IFN D20
;TTYGET TTYSET SCML CNSGET OPNAT3 OPNAT5 OPEN4
IFN ITS,[
TTYGET: SETZ
SIXBIT \TTYGET\ ;GET TTYST1, TTYST2, TTYSTS
,,F.CHAN(TT) ;TTY CHANNEL #
2000,,D ;TTYST1
2000,,R ;TTYST2
402000,,F ;TTYSTS
TTYSET: SETZ
SIXBIT \TTYSET\ ;SET TTYST1, TTYST2, TTYSTS
,,F.CHAN(TT) ;TTY CHANNEL #
,,TI.ST1(TT) ;TTYST1
,,TI.ST2(TT) ;TTYST2
400000,,F ;TTYSTS
SCML: SETZ
SIXBIT \SCML\ ;SET NUMBER OF COMMAND LINES
,,F.CHAN(TT) ;TTY CHANNEL #
401000,,5 ;NUMBER OF LINES
CNSGET: SETZ
SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS
,,F.CHAN(TT) ;TTY CHANNEL #
2000,,FO.RPL(TT) ;VERTICAL SCREEN SIZE
2000,,FO.LNL(TT) ;HORIZONTAL SCREEN SIZE
2000,,D ;TCTYP (THROW AWAY)
2000,,D ;TTYCOM (THROW AWAY)
402000,,D ;TTYOPT
;TTYTYP NOT GOTTEN
] ;END OF IFN ITS
OPNAT3: TRNE T,2
JRST OPNAT5
SETZM AT.CHS(TT)
SETZM AT.LNN(TT)
OPNAT5: MOVEI D,1
MOVEM D,AT.PGN(TT)
OPEN4: POP FXP,F.MODE(TT)
POP P,A ;SAR FOR FILE ARRAY - RETURNED
MOVEI TT,-1
SETZM @TTSAR(A) ;ILLEGAL FOR LOSER TO ACCESS AS ARRAY
MOVSI TT,TTS<CL>
ANDCAM TT,TTSAR(A) ;UNCLOSE IT
POPI P,3 ;FLUSH 2 ARGS AND # OF ARGS
20$ SETZB 2,3 ;MAKE SURE AC'S CONTAIN NO JUNK
UNLKPOPJ ;WE HAVE WON!
;OPNALZ OPENLZ OPNLZ0 OPNLZ3 OPNLZ2 OPNAND OPNLZ1 OPNLZS OPNLZR
;;; VARIOUS ERROR HANDLERS - ARRIVE WITH A MESSAGE IN C.
OPNALZ: MOVEI C,[SIXBIT \ALL I/O CHANNELS ALREADY IN USE!\]
POP FXP,-L.F6BT-1(FXP) ;FAKE OUT CORRECT PDL CONDITIONS
POPI FXP,L.F6BT-1
OPENLZ: MOVE F,F.CHAN(TT) ;REMEMBER, C HAS ERROR MSG
SETZM CHNTB(F) ;CLOSE CHANNEL AND DEALLOCATE
IFN ITS,[
.CALL ALCHN9
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
LSH F,27
IOR F,[RELEASE 0,0]
XCT F
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT)
CLOSF
HALT
] ;END OF IFN D20
OPNLZ0: POP P,AR1 ;FILE OBJECT SAR
POP P,A ;SECOND ARG
POP P,B ;FIRST ARG
POP P,T ;ARG COUNT
JUMPN T,OPNLZ3
MOVEI A,(AR1)
PUSHJ P,NAMELIST
JRST OPNLZ2
OPNLZ3: PUSHJ P,ACONS
EXCH A,B
PUSHJ P,ACONS
CAMN T,XC-2
HRRM B,(A)
OPNLZ2: MOVEI B,Q$OPEN
POPI FXP,1
UNLOCKI
JRST XCIOL
IFN D10,[
OPNAND: MOVEI C,NSDERR ;NO SUCH DEVICE
OPNLZ1: POPI FXP,1
JRST OPNLZ0
] ;END OF IFN D10
IFN SAIL,[
OPNLZS: POPI FXP,2
JRST OPNLZ0
] ;END IFN SAIL
IFN D20,[
OPNLZR: RLJFN
HALT
JRST OPNLZ0
] ;END OF IFN D20
;OPENUP FILLEN ACCESS RCHST
IFN ITS,[
OPENUP: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,(D) ;I/O MODE BITS
,,F.CHAN(TT) ;CHANNEL #
,,F.DEV(TT) ;DEVICE NAME
,,F.FN1(TT) ;FILE NAME 1
,,F.FN2(TT) ;FILE NAME 2
400000,,F.SNM(TT) ;SNAME
FILLEN: SETZ
SIXBIT \FILLEN\ ;GET FILE LENGTH (IN WORDS)
,,F.CHAN(TT) ;CHANNEL #
402000,,F.FLEN(TT) ;PUT RESULT IN F.FLEN OF THE FILE OBJECT
ACCESS: SETZ
SIXBIT \ACCESS\ ;SET FILE ACCESS POINTER
,,F.CHAN(TT) ;CHANNEL #
400000,,F.FPOS(TT) ;POSITION
RCHST: SETZ
SIXBIT \RCHST\ ;READ CHANNEL STATUS
,,F.CHAN(TT) ;CHANNEL #
2000,,F.RDEV(TT) ;DEVICE NAME
2000,,F.RFN1(TT) ;FILE NAME 1
2000,,F.RFN2(TT) ;FILE NAME 2
2000,,F.RSNM(TT) ;SNAME
402000,,F.FLEN(TT) ;ACCESS POINTER
] ;END OF IFN ITS
;OPEN9A OPEN9B OPEN9D
;;; TABLES FOR OPEN FUNCTION
;;; ALL TABLES ARE INDEXED BY THE RIGHT HALF OF THE MODE WORD.
IT$ RBFSIZ==:200 ;RANDOM BUFFER SIZE
20$ RBFSIZ==:200
10$ RBFSIZ==:0
;;; SIZES FOR FILE ARRAYS: <BLOCKMODE SIZE>,,<CHARMODE SIZE>
;;; FOR D10, THIS IS THE SIZE EXCLUSIVE OF THE BUFFER; FOR ITS AND D20, INCLUSIVE.
;;; SIZES ARE IN WORDS.
OPEN9A: FB.BUF+RBFSIZ,,FB.BUF ;ASCII DSK INPUT
FB.BUF+RBFSIZ,,FB.BUF ;ASCII DSK OUTPUT
,,FB.BUF+NASCII/2 ;ASCII TTY INPUT
FB.BUF+RBFSIZ,,FB.BUF ;ASCII TTY OUTPUT
FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM DSK INPUT
FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM DSK OUTPUT
,,FB.BUF+NASCII/2 ;FIXNUM TTY INPUT
FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM TTY OUTPUT
FB.BUF+RBFSIZ,,FB.BUF ;IMAGE DSK INPUT
FB.BUF+RBFSIZ,,FB.BUF ;IMAGE DSK OUTPUT
,,FB.BUF+NASCII/2 ;IMAGE TTY INPUT
FB.BUF+RBFSIZ,,FB.BUF ;IMAGE TTY OUTPUT
;;; <BITS FOR LEFT HALF OF TTSAR>,,<BLOCK MODE BUFFER SIZE>
;;; THE RIGHT HALF IS NOT REALLY USED FOR D10.
OPEN9B:
IRP X,,[A,X,I]J,,[,+BN,+IM] ;ASCII/FIXNUM/IMAGE
IRP Y,,[D,T]K,,[,+TY] ;DSK/TTY
IRP Z,,[I,O]L,,[,+IO] ;IN/OUT
IFSE X!!Y!!Z,IDI, LDGTW5: .SEE LDGTWD ;CROCK
TTS<CL!J!!K!!L>,,RBFSIZ
TERMIN
TERMIN
TERMIN
;;; <LEFT HALF FOR FB.IBP>,,<BYTES PER WORD>
;;; RELEVANT ONLY FOR BLOCK MODE FILES. ONLY THE RIGHT HALF IS USED FOR D10.
OPEN9D: 010700,,5 ;ASCII DSK INPUT
010700,,5 ;ASCII DSK OUTPUT
0 ;ASCII TTY INPUT (IRRELEVANT)
010700,,5 ;ASCII TTY OUTPUT
004400,,1 ;FIXNUM DSK INPUT
004400,,1 ;FIXNUM DSK OUTPUT
0 ;FIXNUM TTY INPUT (IRRELEVANT)
IT$ 001400,,3 ;FIXNUM TTY OUTPUT
10$ SA% 010700,,5
10$ SA$ 001100,,4
20$ 010700,,5
010700,,5 ;IMAGE DSK INPUT
010700,,5 ;IMAGE DSK OUTPUT
0 ;IMAGE TTY INPUT (IRRELEVANT)
10% 041000,,4 ;IMAGE TTY OUTPUT
10$ SA% 010700,,5
10$ SA$ 001100,,4 ? WARN [IMAGE TTY OUTPUT?]
;OPEN9C $EOPEN $EOPN1 $EOPN2 $EOPN3 $EOPN6 $EOPN5 $EOPN7 $EOPN8 $EOPN9 $EOPN4
;;; OPEN9C CONTAINS THE OPEN MODE WORD. FOR D10, THE MODE IS ALWAYS
;;; BLOCK MODE IF THIS TABLE IS USED. FOR D20, THERE IS NO DIFFERENCE
;;; IN THIS TABLE FOR BLOCK VERSUS SINGLE MODE.
OPEN9C:
IFN ITS,[
;;; RECALL THE MEANINGS OF THE FOLLOWING BITS IN ITS:
;;; 1.3 0 => ASCII, 1 => IMAGE
;;; 1.2 0 => UNIT (CHARACTER) MODE, 1 => BLOCK MODE
;;; 1.1 0 => INPUT, 1 => OUTPUT
;;; ITS BLOCK MODE IS NOT USED FOR BUFFERED FILES; RATHER, SIOT IS USED.
0 ;ASCII DSK INPUT
1 ;ASCII DSK OUTPUT
0 ;ASCII TTY INPUT
%TJDIS+1 ;ASCII TTY OUTPUT (DISPLAY IF POSSIBLE)
4 ;FIXNUM DSK INPUT
5 ;FIXNUM DSK OUTPUT
%TIFUL+0 ;FIXNUM TTY INPUT (>7 BITS ON IMLACS AND TVS)
%TJDIS+1 ;FIXNUM TTY OUTPUT
0 ;IMAGE DSK INPUT
1 ;IMAGE DSK OUTPUT
0 ;IMAGE TTY INPUT (SUPER-IMAGE INPUT)
%TJSIO+1 ;IMAGE TTY OUTPUT (SUPER-IMAGE OUTPUT)
] ;END OF IFN ITS
IFN D10,[
.IOASC ;ASCII DSK INPUT
.IOASC ;ASCII DSK OUTPUT
.IOASC ;ASCII TTY INPUT
.IOASC ;ASCII TTY OUTPUT
.IOBIN ;FIXNUM DSK INPUT
.IOBIN ;FIXNUM DSK OUTPUT
.IOASC ;FIXNUM TTY INPUT
.IOASC ;FIXNUM TTY OUTPUT
.IOASC ;IMAGE DSK INPUT
.IOASC ;IMAGE DSK OUTPUT
.IOIMG ;IMAGE TTY INPUT
.IOIMG ;IMAGE TTY OUTPUT
] ;END OF IFN D10
IFN D20,[
.SEE OF%BSZ OF%MOD
070000,,OF%RD ;ASCII DSK INPUT
070000,,OF%WR ;ASCII DSK OUTPUT
070000,,OF%RD ;ASCII TTY INPUT
070000,,OF%WR ;ASCII TTY OUTPUT
440000,,OF%RD ;FIXNUM DSK INPUT
440000,,OF%WR ;FIXNUM DSK OUTPUT
070000,,OF%RD ;FIXNUM TTY INPUT
070000,,OF%WR ;FIXNUM TTY OUTPUT
070000,,OF%RD ;IMAGE DSK INPUT
070000,,OF%WR ;IMAGE DSK OUTPUT
100000,,OF%RD ;IMAGE TTY INPUT
100000,,OF%WR ;IMAGE TTY OUTPUT
] ;END OF IFN D20
IFN SAIL,[
;EOPEN FOR SAIL -- HANDLE 'E' FILES
;;; DO AN OPEN, THEN, IF THE FILE IS OPEN IN NON-IMAGE NON-TTY ASCII MODE SKIP
;;; OVER E'S COMMENT BY DOING SUCCESIVE IN'S
$EOPEN: MOVEI TT,(P) ;MUST CALCULATE WHERE RETURN ADR IS
ADD TT,T ;SUBTRACT NUMBER OF ARGS GIVEN
PUSH FXP,(TT) ;REMEMBER USER'S RETURN ADR
MOVEI R,$EOPN1 ;NEW RETURN ADR
MOVEM R,(TT)
JRST $OPEN ;NOW OPEN THE FILE
$EOPN1: MOVEI TT,F.MODE ;GET MODE OF FILE
HRRZ TT,@TTSAR(A)
SKIPE TT ;ASCII, DSK, INPUT?
POPJ FXP, ;NOPE, JUST RETURN
PUSH P,A ;REMEMBER FILE ARRAY
PUSH FXP,[440700,,[ASCIZ \COMMENT ⊗\]]
$EOPN2: ILDB T,(FXP) ;GET NEXT CHARACTER TO LOOK FOR
JUMPE T,$EOPN5 ;LOOKS LIKE WE FOUND AN 'E' FILE, SKIP INDEX
PUSH P,[$EOPN3] ;RETURN ADR
PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM
MOVNI T,1 ;ONE ARG
JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL)
$EOPN3: JUMPL TT,$EOPN4 ;EOF -- ERROR!
LDB T,(FXP) ;GET THE CURRENT CHARACTER
CAIN T,(TT) ;MATCH?
JRST $EOPN2 ;YES, KEEP SCANNING THE FILE
PUSH P,[$EOPN6] ;NOPE, FILEPOS TO BOF
PUSH P,-1(P) ;FILE ARRAY
PUSH P,CIN0 ;ZERO - LOGICAL BOF
MOVNI T,2 ;TWO ARGS -- SET FILEPOS
JRST FILEPOS
$EOPN6: POPI FXP,1 ;BYTE POINTER
POP P,A ;FILE ARRAY RETURNED IN A
POPJ FXP, ;RETURN TO USER
;HERE WHEN FOUND AN 'E' FILE, SKIP TO AFTER ↑L AFTER NEXT ↑V
$EOPN5: PUSH P,[$EOPN7] ;RETURN ADR
PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM
MOVNI T,1 ;ONE ARG
JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL)
$EOPN7: JUMPL TT,$EOPN4 ;EOF -- ERROR!
CAIE TT,↑V ;FOUND ↑V?
JRST $EOPN5 ;NOPE, KEEP ON LOOPING
$EOPN8: PUSH P,[$EOPN9] ;RETURN ADR
PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM
MOVNI T,1 ;ONE ARG
JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL)
$EOPN9: JUMPL TT,$EOPN4 ;EOF -- ERROR!
CAIE TT,↑L ;FOUND ↑L?
JRST $EOPN8 ;NOPE, KEEP ON LOOPING
POPI FXP,1 ;GET RID OF BYTE POINTER
POP P,A ;RETURN FILE ARRAY
POPJ FXP, ;TO USER
$EOPN4: POP P,A ;FILE ARRAY -- EOF, WE LOST
FAC [EOF READING A FILE WHICH LOOKED LIKE AN 'E' FILE - EOPEN!]
] ;END IFN SAIL
;DEFAULTF SSCRFILE ENDPAGEFN EOFFN EOFFN0 EOFFNZ EOFFN2 EOFFN5 EOFFNY EOFFN7
SUBTTL DEFAULTF, ENDPAGEFN, EOFFN
;;; (DEFAULTF X) SETS THE DEFAULT NAMELIST TO X.
;;; X IS MERGEF'D WITH THE OLD NAMELIST FIRST.
;;; IT FOLLOWS THAT (DEFAULTF NIL) = (NAMELIST NIL).
DEFAULTF:
PUSHJ P,FIL6BT
PUSHJ P,DMRGF
PUSHJ P,6BTNML
MOVEM A,VDEFAULTF
POPJ P,
SSCRFILE==DEFAULTF
;;; (EOFFN F) GETS INPUT FILE F'S END-OF-FILE FUNCTION.
;;; (EOFFN F X) SETS THE FUNCTION TO BE X.
;;; (ENDPAGEFN F) GETS OUTPUT FILE F'S END-OF-PAGE FUNCTION.
;;; (ENDPAGEFN F X) SETS IT TO BE X.
ENDPAGEFN:
JSP TT,LWNACK ;LSUBR (1 . 2)
LA12,,QENDPAGEFN
MOVEI TT,ATOFOK
MOVEI B,DENDPAGEFN
MOVEI C,QENDPAGEFN
JRST EOFFN0
EOFFN: JSP TT,LWNACK ;LSUBR (1 . 2)
LA12,,QEOFFN
MOVEI TT,IFILOK
MOVEI B,DEOFFN
MOVEI C,QEOFFN
EOFFN0: AOJN T,EOFFN5
POP P,AR1
JUMPE AR1,EOFFN2
IFN SFA,[
PUSH FXP,TT
JSP TT,XFOSP ;SFA?
JRST EOFFNZ
JRST EOFFNZ ;NOPE
POPI FXP,1
MOVEI A,(AR1) ;CALL THE SFA, AND RETURN ITS ANSWER
HRRZI B,(C) ;THE OPERATION -- EOFFN OR ENDPAGEFUN
SETZ C, ;WE WANT THE SFA TO RETURN A VALUE
JRST ISTCSH ;SHORT INTERNAL CALL
EOFFNZ: POP FXP,TT
] ;END IFN SFA
PUSHJ P,(TT)
MOVEI TT,FI.EOF .SEE FO.EOP
HRRZ A,@TTSAR(AR1)
UNLKPOPJ
EOFFN2: HRRZ A,(B)
POPJ P,
EOFFN5: POP P,A
POP P,AR1
JUMPE AR1,EOFFN7
IFN SFA,[
PUSH FXP,TT
JSP TT,XFOSP ;CHECK IF WE HAVE AN SFA
JRST EOFFNY
JRST EOFFNY ;NOPE
POPI FXP,1
JSP T,%NCONS ;LISTIFY IT SO IT IS IDENTIFIABLE AS AN ARG
MOVEI B,(C) ;THE OPERATION
MOVEI C,(A) ;AS THE ARG TO THE SFA
MOVEI A,(AR1) ;THE SFA ITSELF
JRST ISTCSH ;DO THE SHORT INTERNAL CALL
EOFFNY: POP FXP,TT ;UNDO PUSHES
] ;END IFN SFA
PUSHJ P,(TT)
MOVE TT,TTSAR(AR1)
HRRZM A,FI.EOF(TT) .SEE FO.EOP
UNLKPOPJ
EOFFN7: HRRZM A,(B)
POPJ P,
;$LISTEN $LSTN3 $LSTNS $LSTN4 $LSTN6 $LSTN5 LISTEN
SUBTTL LISTEN FUNCTION
;;; (LISTEN X) LISTENS TO THE SPECIFIED TTY X.
$LISTEN:
SKIPA F,CFIX1 ;LSUBR (0 . 1) NCALLABLE
MOVEI F,CPOPJ
HRRZ AR1,V%TYI
JUMPE T,$LSTN3
MOVEI D,Q$LISTEN
AOJN T,S1WNAL
POP P,AR1 ;FILE ARRAY SPECIFIED
$LSTN3:
IFN SFA,[
JSP TT,XFOSP ;FILE OR SFA?
JRST $LSTNS
JRST $LSTNS ;NOT AN SFA
JSP T,QIOSAV
MOVEI A,(AR1) ;SFA IN A
MOVEI B,Q$LISTEN ;OPERATION
SETZ C, ;NO THIRD ARG
PUSHJ P,ISTCSH ;SHORT INTERNAL SFA INVOCATION
MOVE TT,(A) ;BE PREPARED IF NCALL'ED
POPJ P,
$LSTNS: ] ;END IFN SFA
PUSHJ P,TIFLOK ;IT BETTER BE TTY INPUT
IFN ITS,[
.CALL LISTEN ;SO LISTEN ALREADY
SETZ R, ;ON FAILURE, JUST ASSUME 0
] ;END OF IFN ITS
IFN D10,[
SKIPL T,F.MODE(TT) .SEE FBT.CM
SA$ JRST $LSTN4 ? WARN [REALLY OUGHT TO BE SMARTER]
SA% JRST $LSTN5
IFE SAIL,[
TLNE T,FBT.LN
SKIPA D,[SKPINL]
MOVSI D,(SKPINC)
] ;END OF IFE SAIL
IFN SAIL,[
MOVE D,[SNEAKS R,]
JRST $LSTN6
$LSTN4: MOVE D,F.CHAN(TT)
LSH D,27
IOR D,[TTYSKP 0,]
] ;END OF IFN SAIL
$LSTN6: XCT D
$LSTN5: TDZA R,R
MOVEI R,1
] ;END OF IFN D10
IFN D20,[
HRRZ 1,F.JFN(TT)
SIBE ;SKIP IF INPUT BUFFER EMPTY
SKIPA R,2 ;NUMBER OF WAITING CHARS IN 2
SETZ R,
] ;END OF IFN D20
MOVEI TT,FI.BBC
MOVE A,@TTSAR(AR1) ;ALSO COUNT IN ANY BUFFERED
TLZE A,-1 ; UP CHARACTERS PENDING
AOS R
JSP T,LNG1A
ADD TT,R
UNLOCKI
JRST (F)
IFN ITS,[
LISTEN: SETZ
SIXBIT \LISTEN\ ;LISTEN AT A TTY, ALREADY
,,F.CHAN(TT) ;TTY CHANNEL #
402000,,R ;NUMBER OF TYPED-AHEAD CHARS
] ;END OF IFN ITS
;LINEL PAGEL CHARPOS LINENUM PAGENUM FLFWNA FLNSFL FLFROB FLFRFL FLFRF1 FLFRB1 FLFB1A FLFRB3 FLFRB5 FLFRB6 FLFRB8 FLFRB7
SUBTTL LINEL, PAGEL, CHARPOS, LINENUM, PAGENUM
;;; VARIOUS FUNCTIONS TO GET AND SET A FILE'S LINEL, PAGEL,
;;; CHARPOS, LINENUM, AND PAGENUM.
LINEL: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
FO.LNL,,QLINEL
DLINEL,,ATOFOK
PAGEL: SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
FO.PGL,,QPAGEL
DPAGEL,,ATOFOK
CHARPOS:
SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.CHS,,QCHARPOS
0,,ATOFOK
LINENUM:
SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.LNN,,QLINEN
0,,ATFLOK
PAGENUM:
SKIPA D,CFIX1
MOVEI D,CPOPJ
JSP F,FLFROB ;LSUBR (1 . 2)
AT.PGN,,QPAGENUM
0,,ATFLOK
IFN SFA,[
FLFWNA: HRRZ D,(F) ;FUNCTION NAME
JRST WNALOSE ;WNA ERROR
FLNSFL: EXCH AR1,A
WTA [NOT SFA OR FILE!]
] ;END IFN SFA
FLFROB:
IFN SFA,[
CAME T,XC-1 ;WRONG NUMBER OF ARGS?
CAMN T,XC-2
SKIPA
JRST FLFWNA
MOVEI TT,(P) ;TOP OF STACK CONTAINS FILE ARG?
CAMN T,XC-2 ;UNLESS TWO ARGS
MOVEI TT,-1(P)
MOVE A,(TT) ;GET THE ARG
CAIN A,TRUTH
MOVE A,V%TYO
MOVEM A,(TT) ;RE-STORE IT INCASE IT HAS BEEN ALTERED
JUMPE A,FLFRF1 ;IF NIL THEN HANDLE SPECIALLY
EXCH A,AR1
JSP TT,XFOSP
JRST FLNSFL ;NOT AN SFA OR FILE
JRST FLFRFL
AOSE T ;HAVE TWO ARGS?
POP P,AR1 ;YES, IT WILL BECOME SECOND ARG TO SFA
EXCH AR2A,(P) ;SAVE AR2A ON STACK, GET SFA
PUSH P,A ;SAVE OLD AR1
PUSH P,C
PUSH P,B
MOVEI A,(AR2A) ;SFA INTO A
HRRZ B,(F) ;OPERATION NAME INTO B
MOVEI C,(AR1) ;THIRD ARG
PUSHJ P,ISTCSH
POP P,B
POP P,C
POP P,AR1
POP P,AR2A
JSP T,FXNV1 ;MAKE SURE RESULT IS A FIXNUM
POPJ P,
FLFRFL: EXCH A,AR1
FLFRF1: ] ;END IFN SFA
AOJN T,FLFRB5
PUSH P,AR1
MOVE AR1,-1(P)
MOVEM D,-1(P)
JUMPE AR1,FLFRB3
FLFRB1: HRRZ TT,1(F)
PUSHJ P,(TT)
HLRZ TT,(F)
MOVM TT,@TTSAR(AR1) .SEE STERPRI ;LINEL MAY BE NEGATIVE
UNLOCKI
FLFB1A: POP P,AR1
POPJ P,
FLFRB3: HLRZ TT,1(F)
JUMPE TT,FLFRB1
MOVE TT,(TT)
JRST FLFB1A
FLFRB5: POP P,A
JSP T,FXNV1
PUSH P,AR1
MOVE AR1,-1(P)
MOVEM D,-1(P)
MOVE D,TT
JUMPE AR1,FLFRB7
FLFRB6: HRRZ TT,1(F)
PUSHJ P,(TT)
HLRZ TT,(F)
MOVMS D
EXCH D,@TTSAR(AR1)
SKIPGE D
MOVNS @TTSAR(AR1)
UNLOCKI
FLFRB8: MOVE TT,D
JRST FLFB1A
FLFRB7: HLRZ TT,1(F)
JUMPE TT,FLFRB6
MOVMM D,(TT)
JRST FLFRB8
;$IN $INNOS $IN2 $IN1 $IN3 $IN4 $IN7 $IN8 INSIOT
SUBTTL IN
;;; (IN X) INPUTS ONE FIXNUM FROM THE BINARY FILE X AND
;;; RETURNS IT.
$IN: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE - ACS 1
PUSH P,AR1
IFN SFA,[
JSP TT,AFOSP ;FILE OR SFA OR NOT?
JFCL ;NOT, LET OTHER CODE GIVE ERROR
JRST $INNOS ;NOT SFA, PROCEED
POP P,AR1
PUSHJ FXP,SAV5M1 ;SAVE ALL BUT A
MOVEI B,Q$IN ;IN OPERATION
SETZ C, ;NO THIRD ARG
PUSHJ P,ISTCSH ;SHORT +INTERNAL-SFA-CALL
PUSHJ P,RST5M1
MOVE T,CFIX1
CAMN T,(P) ;NCALL'ED?
POPI P,1 ;YUP, WILL RETURN ARGS IN BOTH A AND TT
JSP T,FXNV1 ;INSURE A FIXNUM
POPJ P, ;RETURN
$INNOS: ] ;END IFN SFA
MOVEI AR1,(A)
PUSHJ P,XIFLOK ;LOCKI
IFN ITS+D20,[
MOVEI R,(TT) ;SAVE A COPY OF TTSAR
SKIPL F.MODE(TT) .SEE FBT.CM
JRST $IN2
;FOR ITS AND D20, HANDLE SINGLE MODE FILES
IFN ITS,[
PUSH FXP,[%TIACT] ;ASSUME A TTY
TLNN TT,TTS.TY ;A TTY?
SETZM (FXP) ;NO, SO NO FLAG BITS
MOVE T,[444400,,TT] ;READ ONE 36.-BIT BYTE INTO TT
MOVEI D,1
.CALL INSIOT
.LOSE 1400
POPI FXP,1
JUMPN D,$IN7 ;IF WE GOT NO WORD, ASSUME EOF
] ;END OF IFN ITS
IFN D20,[
PUSH P,B ;PRESERVE AC'S
PUSH P,C
HRRZ 1,F.JFN(TT)
MOVE 2,[444400,,TT] ;READ ONE 36.-BIT BYTE INTO TT
MOVNI 3,1
SIN ;"STRING" INPUT
POP P,C
POP P,B
JUMPN D,$IN7 ;NO BYTE MEANS EOF
] ;END OF IFN D20
AOS F.FPOS(R)
JRST $IN1
] ;END OF IFN ITS+D20
IFN D10,[
SKIPGE F.MODE(TT) .SEE FBT.CM
HALT ;SINGLE MODE BINARY FILE IS ILLEGAL
] ;END OF IFN D10
$IN2:
10$ HRRZ D,FB.HED(TT)
10% SOSGE FB.CNT(TT) ;ARE THERE ANY BYTES LEFT?
10$ SOSGE 2(D)
JRST $IN3 ;NO, GO GET ANOTHER BUFFER FULL
10% ILDB TT,FB.BP(TT) ;YES, GOBBLE DOWN THE NEXT BYTE
10$ ILDB TT,1(D)
$IN1: POP P,AR1
UNLKPOPJ
;GET THE NEXT INPUT BUFFER
$IN3:
IFN ITS,[
MOVE T,FB.IBP(TT)
MOVEM T,FB.BP(TT) ;REINITIALIZE BYTE POINTER
MOVE D,FB.BVC(TT)
ADDM D,F.FPOS(TT) ;UPDATE FILE POSITION
MOVE D,FB.BFL(TT) ;GET BUFFER LENGTH INTO D
MOVE R,D ;GET NEXT BUFFER-LOAD
.CALL SIOT
.LOSE 1400
SUB R,D ;GET COUNT OF BYTES OBTAINED
MOVEM R,FB.CNT(TT)
MOVEM R,FB.BVC(TT)
JUMPN R,$IN2 ;EXIT IF WE GOT ANY (ELSE EOF)
] ;END OF IFN ITS
IFN D10,[
MOVE F,FB.BVC(TT)
ADDM F,F.FPOS(TT) ;UPDATE FILE POSITION
HRRZ F,F.CHAN(TT)
LSH F,27
IOR F,[IN 0,]
XCT F ;GET NEXT INPUT BUFFER
JRST $IN4 ;SUCCESS
XOR F,[<STATO 0,IO.EOF>#<IN 0,>]
XCT F ;SKIP IF EOF
HALT ;ERROR IF NOT EOF?
$IN4: MOVE F,2(D) ;GET, FROM HEADER, NUMBER OF BYTES READ
MOVEM F,FB.BVC(TT) ;STORE IN BUFFER VALID COUNT
JUMPG F,$IN2 ;IF READ ANYTHING THEN USE IT
] ;END OF IFN D10
IFN D20,[
PUSH P,B
PUSH P,C
HRRZ 1,F.JFN(TT)
MOVE 2,FB.IBP(TT)
MOVEM 2,FB.BP(TT)
MOVN 3,FB.BFL(TT)
SIN ;"STRING" INPUT
MOVE D,FB.BVC(TT)
ADDM D,F.FPOS(TT)
ADD D,3
MOVEM D,FB.CNT(TT) ;ACTUAL COUNT OF BYTES OBTAINED
MOVEM D,FB.BVC(TT)
POP P,C
POP P,B
JUMPN D,$IN2 ;JUMP IF WE GOT AT LEAST ONE BYTE
PUSH P,B
GTSTS ;GET FILE STATUS
TLNN 2,(GS%EOF) ;SKIP ON EOF
HALT ;HALT FOR OTHER LOSS
POP P,B
] ;END OF IFN D20
$IN7: MOVEI A,(AR1) ;NO DATA WORDS - EOF
HRRZ T,FI.EOF(TT)
UNLOCKI
POP P,AR1
JUMPE T,$IN8
JCALLF 1,(T) ;CALL USER EOF FUNCTION
$IN8: PUSH P,B ;NO USER EOF FUNCTION
PUSHJ P,NCONS
MOVEI B,Q$IN
PUSHJ P,XCONS
POP P,B
IOL [EOF - IN!] ;SIGNAL ERROR
IFN ITS,[
INSIOT: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
,,T ;BYTE POINTER
,,D ;BYTE COUNT
404000,,(FXP)
] ;END IFN ITS
;$OUT $OUTNS $OUT3 $OUT2 $OUT1
SUBTTL OUT
;;; (OUT X N) OUTPUTS THE FIXNUM N TO THE FILE X. RETURNS T.
$OUT: PUSH P,AR1 ;SUBR 2 - ACS 1
IFN SFA,[
JSP TT,AFOSP ;FILE OR SFA OR NOT?
JFCL ;NOT, LET OTHER CODE GIVE ERROR
JRST $OUTNS ;NOT SFA, PROCEED
POP P,AR1
JSP T,QIOSAV
MOVEI C,(B) ;ARG IS FIXNUM TO OUTPUT
MOVEI B,Q$OUT ;OUT OPERATION
JRST ISTCSH ;SHORT +INTERNAL-SFA-CALL
$OUTNS: ] ;END IFN SFA
JSP T,FXNV2
MOVEI AR1,(A)
PUSHJ P,XOFLOK
SKIPL F.MODE(TT) .SEE FBT.CM
JRST $OUT2
;OUTPUT ONE BYTE TO A SINGLE MODE BINARY FILE
10$ HALT ;SINGLE MODE BINARY FILE ILLEGAL FOR D10
IFN ITS,[
MOVE R,D
MOVEI D,1
MOVE T,[444400,,R]
.CALL SIOT
.LOSE 1400
] ;END OF IFN ITS
IFN D20,[
PUSH P,B
PUSH P,C
HRRZ 1,F.JFN(TT)
MOVE 2,[444400,,D]
MOVNI 3,1
SOUT
POP P,C
POP P,B
] ;END OF IFN D20
IFN ITS+D20,[
AOS F.FPOS(TT)
JRST $OUT1
] ;END OF IFN ITS+D20
$OUT3: PUSH FXP,D
10% SETZM FB.CNT(TT) ;DOING OWN BUFFERED I/O, -1 IN FB.CNT IS N.G.
PUSHJ P,IFORCE ;FORCE OUT CURRENT OUTPUT BUFFER
POP FXP,D
$OUT2:
10$ HRRZ R,FB.HED(TT)
10% SOSGE FB.CNT(TT) ;SEE IF THERE IS ROOM FOR ANOTHER BYTE
10$ SOSGE 2(R)
JRST $OUT3 ;NO, GO OUTPUT THIS BUFFER FIRST
10% IDPB D,FB.BP(TT) ;STICK BYTE IN BUFFER
10$ IDPB D,1(R)
$OUT1: POP P,AR1
JRST UNLKTRUE
;FILEPOS FPOS0E FPOS0B FPOS0C FPOS0D FPOS0 FPOS0A FPOS1 FP1SF1 FPOS1A FPOS1C FPOS2
SUBTTL FILEPOS, LENGTHF
;;; FILEPOS FUNCTION
;;; (FILEPOS F) RETURNS CURRENT FILE POSITION
;;; (FILEPOS F N) SETQ FILEPOS TO X
;;; FOR ASCII FILES, THE POSITION IS MEASURED IN CHARACTERS;
;;; FOR FIXNUM FILES, IN FIXNUMS (WORDS). ZERO IS THE
;;; BEGINNING OF THE FILE. ERROR IF FILE IS NOT RANDOMLY
;;; ACCESSIBLE.
FILEPOS:
AOJE T,FPOS1 ;ONE ARG => GET
AOJE T,FPOS5 ;TWO ARGS => SET
MOVEI D,QFILEPOS ;ARGH! ARGH! ARGH! ...
JRST S2WNALOSE
IFN D20,[
FPOS0E: POP P,B
JRST FPOS0D
] ;END OF IFN D20
FPOS0B: SKIPA C,FPOS0
FPOS0C: MOVEI C,[SIXBIT \ILLEGAL ACCESS POINTER!\]
FPOS0D: MOVEI A,(B) ;COME HERE FOR TWO-ARG CASE,
PUSHJ P,NCONS ; MESSAGE IN C
JRST FPOS0A
FPOS0: MOVEI C,[SIXBIT \FILE NOT RANDOMLY ACCESSIBLE!\]
SETZ A, ;HERE FOR ONE-ARG ERROR, MESSAGE IN C
FPOS0A: MOVEI B,(AR1)
PUSHJ P,XCONS
MOVEI B,QFILEPOS
UNLOCKI
JRST XCIOL
;ONE-ARGUMENT CASE: GET FILE POSITION
FPOS1: POP P,AR1 ;ARG IS FILE
IFN SFA,[
JSP TT,XFOSP ;DO WE HAVE AN SFA?
JRST FP1SF1 ;NOPE
JRST FP1SF1 ;NOPE
MOVEI A,(AR1) ;YES, CALL THE STREAM
MOVEI B,QFILEPOS
SETZ C, ;NO ARGS
JRST ISTCSH
FP1SF1: ] ;END IFN SFA
PUSHJ P,FILOK ;DOES LOCKI
SKIPGE F.FLEN(TT)
JRST FPOS0 ;ERROR IF NOT RANDOMLY ACCESSIBLE
SKIPGE D,F.FPOS(TT)
JRST FPOS1A
10$ MOVE R,FB.HED(TT)
ADD D,FB.BVC(TT)
10% SUB D,FB.CNT(TT) ;FOR BUFFERED FILES, ADJUST FOR COUNT
10$ SUB D,2(R)
FPOS1A: TLNN TT,TTS<IO>
SKIPN B,FI.BBC(TT)
JRST FPOS2
TLZE B,-1 ;ALLOW FOR ANY BUFFERED BACK CHARS
SUBI D,1
FPOS1C: JUMPE B,FPOS2
HRRZ B,(B)
SA% SKIPLE D
SA$ CAMLE D,FB.ROF(TT) ;FOR SAIL, MAY BE AS LOW AS RECORD OFFSET
SOJA D,FPOS1C
FPOS2: MOVE TT,D ;RETURN POSITION AS FIXNUM
UNLOCKI
JRST FIX1
;FPOS5 FP5SF1 FPOS5A FPOS6 FPOSZ FPOS6C FPOS6B FPOS6A FPOS7 $LENWT $LENGTHF $LENFL
;TWO-ARGUMENT CASE: SET FILE POSITION
FPOS5: POP P,B ;SECOND ARG IS T, NIL, OR FIXNUM
POP P,AR1 ;FIRST IS FILE
IFN SFA,[
JSP TT,XFOSP ;DO WE HAVE AN SFA?
JRST FP5SF1 ;NOPE, CONTINUE
JRST FP5SF1 ;NOPE
MOVEI A,(B) ;LISTIFY THE ARG
JSP T,%NCONS
MOVEI C,(A) ;PASS IT AS THE ARG TO THE SFA
MOVEI A,(AR1) ;THE SFA
MOVEI B,QFILEPOS ;FILEPOS OPERATION
JRST ISTCSH
FP5SF1: ] ;END IFN SFA
SETZ D,
JUMPE B,FPOS5A ;NIL MEANS ABSOLUTE BEGINNING OF FILE
CAIE B,TRUTH ;T MEANS END OF FILE
JSP T,FXNV2 ;OTHERWISE A FIXNUM POSITION
FPOS5A: PUSHJ P,FILOK ;DOES LOCKI, SAVES D
10$ TLNN TT,TTS.IO ;OUTPUT LOSES FOR D10
SKIPGE F.FLEN(TT) ;NOT RANDOMLY ACCESSIBLE?
JRST FPOS0C
SA% JUMPL D,FPOS0C ;FOR NON-SAIL, NEGATIVE POSITION ILLEGAL
SA$ CAMGE D,FB.ROF(TT) ;FOR SAIL, MAY BE DOWN TO RECORD OFFSET
SA$ JRST FPOS0C
IFN ITS+D20,[
TLNN TT,TTS.IO
JRST FPOS6
PUSH FXP,D
PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER
POP FXP,D
MOVE R,F.FPOS(TT) ;CALCULATE PRESENT FILE POSITION
SKIPL F.MODE(TT)
ADD R,FB.BVC(TT)
SKIPL F.MODE(TT)
SUB R,FB.CNT(TT)
CAMLE R,F.FLEN(TT) ;ADJUST LENGTH UPWARD IF NECESSARY
MOVEM R,F.FLEN(TT)
FPOS6:
] ;END OF IFN ITS+D20
CAMLE D,F.FLEN(TT)
JRST FPOS0C ;LOSE IF SPECIFIED POSITION GREATER THAN LENGTH
SA$ CAIN B,NIL ;R IS BY DEFAULT 0, BUT FOR SAIL
SA$ MOVE D,FB.ROF(TT) ; NIL MEANS USE THE RECORD OFFSET
CAIN B,TRUTH
MOVE D,F.FLEN(TT)
IFE D10,[
TLNE TT,TTS.IO ;DETERMINE IF BYTE WE DESIRE IS IN THE BUFFER
JRST FPOSZ ; IF AN INPUT FILE
MOVE R,F.FPOS(TT) ;POSITION OF FIRST BYTE IN BUFFER
CAMGE D,R ;IF TARGET TOO SMALL THEN MUST DO I/O
JRST FPOSZ
ADD R,FB.BVC(TT) ;ADD IN NUMBER OF BYTES IN THE BUFFER
CAML D,R ;IF TARGET TOO LARGE THEN ALSO MUST DO I/O
JRST FPOSZ
MOVE R,F.FPOS(TT) ;IN RANGE, GET POS OF FIRST BYTE IN BUFFER
SUBM D,R ;MAKE R INTO BYTE OFFSET INTO BUFFER
MOVE D,FB.IBP(TT) ;RESTORE BYTE POINTER
MOVEM D,FB.BP(TT)
MOVE D,FB.BVC(TT) ;GET VALID NUMBER OF BYTES IN BUFFER
SUBI D,(R) ;NUMBER OF BYTES REMAINING
MOVEM D,FB.CNT(TT) ; IS THE NEW COUNT
KAKI SKIPE R
KAKI IBP FB.BP(TT) ;SKIP APPROPRIATE NUMBER OF BYTES
KAKI SOJG R,.-1
KL ADJBP R,FB.BP(TT)
KL MOVEM R,FB.BP(TT)
SETZM FI.BBC(TT) ;CLEAR BUFFERED BACK CHARACTER
JRST UNLKTRUE
FPOSZ:
] ;END IFE D10
MOVEM D,F.FPOS(TT)
IFN ITS,[
.CALL ACCESS ;SET FILE POSITION
IOJRST 0,FPOS0D ;JUMP ON FAILURE
] ;END OF IFN ITS
IFN D20,[
PUSH P,B
CAME D,F.FLEN(TT) ;BE ULTRA CAUTIOUS
SKIPA 2,D
SETO 2,
HRRZ 1,F.JFN(TT)
SFPTR ;SET FILE POINTER
IOJRST 0,FPOS0E
POP P,B
] ;END OF IFN D20
IFN D10,[
IDIV D,FB.BFL(TT) ;DIVIDE FILE POSITION BY BUFFER LENGTH
MOVE T,F.CHAN(TT)
LSH T,27
TLO T,(USETI 0,0)
HRRI T,1(D) ;BLOCKS ARE NUMBERED 1-ORIGIN
XCT T ;POSITION FILE TO CORRECT BLOCK
IMUL D,FB.BFL(TT) ;CALCUALTE F.FPOS
MOVEM D,F.FPOS(TT)
MOVE T,FB.HED(TT)
SETZM 2(T) ;ZERO THE REMAINING BYTE COUNT
HRLZI D,400000 ;NOW WE HAVE TO ZERO ALL USE BITS
FPOS6C: HRRZ T,(T) ;GET POINTER TO NEXT BUFFER
SKIPL (T) ;THIS ONE IN USE?
JRST FPOS6B ;NOPE, SO WE ARE DONE
XORM D,(T) ;CLEAR THE USE BIT
JRST FPOS6C ;AND LOOP OVER ALL BUFFERS
FPOS6B:
] ;END OF IFN D10
10% TLNE TT,TTS.IO
10% JRST FPOS6A
SETZM FB.BVC(TT)
SETZM FI.BBC(TT)
; SETZM FI.BBF(TT) ;NOT IMPLEMENTED YET
FPOS6A:
IFN ITS+D20,[
SKIPGE F.MODE(TT)
JRST UNLKTRUE ;THAT'S ALL FOR SINGLE MODE FILES
TLNE TT,TTS.IO
JRST FPOS7 ;JUMP FOR OUTPUT FILES
] ;END OF IFN ITS+D20
MOVE T,TT
10$ PUSH FXP,R ;R HAS DESIRED BYTE WITHIN BLOCK
PUSHJ P,$DEV5K ;GET NEW INPUT BUFFER
JFCL ;IGNORE EOF
10% JRST UNLKTRUE
IFN D10,[
POP FXP,R
MOVE TT,FB.HED(T)
MOVN D,R
ADDM D,2(TT) ;DECREASE COUNT BY NUMBER OF SKIPPED BYTES
KAKI SKIPE R
KAKI IBP 1(TT) ;SKIP APPROPRIATE NUMBER OF BYTES
KAKI SOJG R,.-1
KL ;DUE TO TOPS-10 LOSSAGE, ADJBP WILL LEAVE BYTE POINTER ALIGNED INCORRECTLY.
KL ; THEREFORE, TO GUARUNTEE CORRECT BIT ALIGNMENT, 1 IBP MUST BE DONE BY HAND
KL JUMPLE R,UNLKTRUE
KL IBP 1(TT)
KL SOJLE R,UNLKTRUE
KL ADJBP R,1(TT)
KL MOVEM R,1(TT)
] ;END OF IFN D10
JRST UNLKTRUE
IFN ITS+D20,[
FPOS7: JSP D,FORCE6 ;INITIALIZE OUTPUT POINTERS
JRST UNLKTRUE
] ;END OF IFN ITS+D20
;;; LENGTHF -- SUBR, 1 ARG, NCALLABLE
;;; RETURNS THE LENGTH OF AN OPEN FILE
$LENWT: EXCH A,AR1
SFA% WTA [NOT A FILE - LENGTHF!]
SFA$ WTA [NOT A FILE OR SFA - LENGTHF!]
$LENGTHF:
PUSH P,CFIX1 ;STANDARD ENTRY, RETURN FIXNUM
;ALTERNATE ENTRY, RETURN NUMBER IN TT
EXCH A,AR1 ;FILE/SFA INTO AR1
JSP TT,XFOSP ;MUST BE EITHER
JRST $LENWT
IFN SFA,[
JRST $LENFL
EXCH AR1,A
JSP T,QIOSAV
MOVEI B,Q$LENGTHF
SETZ C,
PUSHJ P,ISTCSH ;SHORT INTERNAL SFA CALL
MOVE T,CFIX1
CAMN T,(P) ;WE WILL RETURN RESULTS IN A AND TT, SO NO NEED TO RECONS
POPI P,1
JSP T,FXNV1
POPJ P,
$LENFL: ] ;END IFN SFA
EXCH A,AR1
MOVEI TT,F.FLEN ;GET FILE LENGTH
MOVE TT,@TTSAR(A)
POPJ P, ;RETURNS TO CFIX1 OR CPOPJ
;CNPCOD CNPCUR CNPCD1 CNPCD2 CNPC9 VAROPT CNPOK
SUBTTL CONTROL-P CODES AND TTY INITIALIZATION
IFN ITS,[
;;; PUSH A ↑P CODE INTO A TTY FILE ARRAY IN AR1.
;;; THE CHARACTER TO FOLLOW THE ↑P IS IN D.
;;; IF THE CHARACTER IS "H, "I, OR "V, THEN THE SECOND
;;; CHARACTER IS IN THE LEFT HALF OF D.
;;; CHARPOS, LINENUM, AND PAGEL ARE CORRECTLY UPDATED.
;;; I/O LOSSES DUE TO INTERRUPTS BETWEEN ↑P AND THE
;;; NEXT CHARACTER ARE SCRUPULOUSLY AVOIDED.
;;; CLOBBERS T, TT, D, AND F. SAVES R (SEE RUB1C3).
CNPCOD: .5LKTOPOPJ .SEE INTTYR
.SEE CRSRP7
HLLOS NOQUIT
MOVE T,TTSAR(AR1)
.CALL VAROPT ;GET TTYOPT INTO TT
JRST CZECHI ;OH WELL, ASSUME NOTHING IS LEGAL
XCT CNPOK-"A(D) ;IS THIS FUNCTION DOABLE?
JRST CZECHI ;WOULD HAVE NO AFFECT ANYWAY SO JUST RETURN
CNPCUR: MOVE TT,F.MODE(T)
PUSH FXP,D
JUMPL TT,CNPCD1 .SEE FBT.CM
MOVE TT,FB.CNT(T)
SUBI TT,3
JUMPGE TT,CNPCD1
MOVE TT,T ;IF THERE ISN'T ROOM IN THE CURRENT BUFFER
PUSHJ P,IFORCE ; FOR THE WHOLE ↑P CODE SEQUENCE, FORCE
MOVE T,TTSAR(AR1) ; OUT THE BUFFER TO AVOID TIMING ERRORS
CNPCD1: SETZM ATO.LC(T) ;IF USING ↑P CODES, THEN FORGET WE DID LF
MOVEI TT,↑P ;OUTPUT A ↑P
PUSHJ P,TYOF6
HRRZ TT,(FXP) ;OUTPUT THE CHARACTER
PUSHJ P,TYOF6
HLRZ TT,(FXP)
JUMPE TT,CNPCD2
TRZ TT,400000 ;OUTPUT ANY ADDITIONAL MAGIC ARGUMENT
PUSHJ P,TYOF6
CNPCD2: POP FXP,TT
XCT CNPC9-"A(TT) ;ACCOUNT FOR THE EFFECTS OF THE ↑P CODE
.LOSE
CNPC9: JRST CNP.A ;A ADVANCE TO FRESH LINE
JRST CNP.B ;B MOVE BACK 1, WRAPAROUND
JRST CNP.C ;C CLEAR SCREEN
JRST CNP.D ;D MOVE DOWN, WRAPAROUND
JRST CZECHI ;E CLEAR TO EOF
JRST CNP.F ;F MOVE FORWARD 1, WRAPAROUND
JFCL
JRST CNP.H ;H SET HORIZONTAL POSITION
JRST CNP.I ;I NEXT CHARACTER IS ONE-POSITION PRINTING CHAR
JFCL
JRST CZECHI ;K KILL CHARACTER UNDER CURSOR
JRST CZECHI ;L CLEAR TO END OF LINE
JRST CNP.M ;M GO INTO **MORE** STATE, THEN HOME UP
JRST CZECHI ;N GO INTO **MORE** STATE
JFCL
JFCL ;P OUTPUT A ↑P
JFCL ;Q OUTPUT A ↑C
JFCL ;R RESTORE CURSOR POSITION
JFCL ;S SAVE CURSOR POSITION
JRST CNP.T ;T TOP OF SCREEN (HOME UP)
JRST CNP.U ;U MOVE UP, WRAPPING AROUND
JRST CNP.V ;V SET VERTICAL POSITION
JFCL
JRST CNP.X ;X BACKSPACE AND ERASE ONE CHAR
JFCL
JRST CNP.Z ;Z HOME DOWN
JRST CNP.IL ;[ INSERT LINE ;BEWARE THE BRACKETS!
JRST CNP.DL ;\ DELETE LINE
JRST CZECHI ;] SAME AS L (OBSOLETE)
JRST CZECHI ;↑ INSERT CHARACTER
JRST CZECHI ;← DELETE CHARACTER
VAROPT: SETZ
SIXBIT \TTYVAR\
,,F.CHAN(T) ;CHANNEL
[SIXBIT \TTYOPT\] ;READ THE TTYOPT VARIABLE
402000,,TT ;RETURN RESULT INTO TT
;TABLE OF INSTRUCTIONS TO DETERMINE IF A ↑P CODE IS DOABLE ON THE TERMINAL
CNPOK: SKIPA ;A OK ON ALL TTY'S
TLNN TT,%TOMVB ;B ON TTY'S THAT CAN DO IT DIRECTLY
SKIPA ;C THIS HAS SOME AFFECT ON ALL TTY'S
SKIPA ;D
TLNN TT,%TOERS ;E REQUIRES %TOERS
SKIPA ;F
JFCL
SKIPA ;H
TLNN TT,%TOMVU ;I
JFCL
TLNN TT,%TOMVU ;K ASSUME ONLY ON DISPLAY TERMINALS
TLNN TT,%TOERS ;L
SKIPA ;M
SKIPA ;N
JFCL
SKIPA ;P
SKIPA ;Q
TLNN TT,%TOMVU ;R MAKE SAME ASSUMPTION AS K AND S
TLNN TT,%TOMVU ;S
TLNN TT,%TOMVU ;T WHEREAS C IS MEANINGFUL FOR NON-DISPLAYS, I
; DO NOT FEEL THIS IS
TLNN TT,%TOMVU ;U
TLNN TT,%TOMVU ;V
JFCL
;X TTY'S THAT CAN BACKSPACE AND DON'T OVERSTRIKE
; OR THAT CAN ERASE
PUSHJ P,[TLNN TT,%TOMVB ;MUST BE ABLE TO BACK-UP
POPJ P,
TLNN TT,%TOERS ;IF CAN ERASE IS OK
TLNN TT,%TOOVR ;OR IF DOESN'T OVERSTRIKE
AOS (P)
POPJ P,]
JFCL
TLNN TT,%TOMVU ;Z SAME CRITERIA AS ↑PT
TLNN TT,%TOLID ;[
TLNN TT,%TOLID ;\
TLNN TT,%TOERS ;] SAME AS ↑PL
TLNN TT,%TOCID ;↑
TLNN TT,%TOCID ;←
;CNP.X CNP.B CNP.M CNP.C CNP.T CNP.IL CNP.DL CNP.A CNP.D CNP.F CNP.H CNP.H1 CNP.I CNP.Z CNP.U CNP.V CNPBBL CNPBL CNPL CNPU CNPF CLRSRN CLRSRN
;;; IFN ITS
CNP.X: ;SAME AS ↑P K ↑P B
CNP.B: MOVE D,FO.LNL(T) ;MOVE BACKWARDS
SUBI D,1
SOSGE AT.CHS(T) ;WRAP AROUND IF AT LEFT MARGIN
MOVEM D,AT.CHS(T)
JRST CZECHI
CNP.M: ;DOES **MORE**, THEN HOMES UP
CNP.C: AOS AT.PGN(T) ;CLEAR SCREEN - AOS PAGENUM
CNP.T: SETZM AT.LNN(T) ;HOME UP - CLEAR LINENUM AND CHARPOS
CNP.IL: ;INSERT LINE - CLEAR CHARPOS
CNP.DL: ;DELETE LINE - CLEAR CHARPOS
SETZM AT.CHS(T)
JRST CZECHI
CNP.A: SKIPN AT.CHS(T) ;CRLF, UNLESS AT START OF LINE
JRST CZECHI
SETZM AT.CHS(T) ;CLEAR CHARPOS, THEN INCR LINENUM
CNP.D: AOS D,AT.LNN(T) ;MOVE DOWN
CAML D,FO.PGL(T) ;WRAP AROUND OFF BOTTOM TO TOP
SETZM AT.LNN(T)
JRST CZECHI
CNP.F: AOS D,AT.CHS(T) ;MOVE FORWARD - WRAP AROUND
CAML D,FO.LNL(T) ; OFF END TO LEFT MARGIN
SETZM AT.CHS(T)
JRST CZECHI
CNP.H: HLRZ D,TT ;SET HORIZONTAL POSITION
TRZ D,400000 ;CLEAR LISP'S FLAG (IF PRESENT)
SUBI D,7 ;ACCOUNT FOR ITS'S 8
SKIPGE FO.LNL(T) ;IF NEGATIVE, THEN ASSUME C(D) IS ACTUAL HPOS
JRST CNP.H1
CAMLE D,FO.LNL(T) ;PUT ON RIGHT MARGIN IF TOO BIG
MOVE D,FO.LNL(T)
CNP.H1: SUBI D,1
MOVEM D,AT.CHS(T)
JRST CZECHI
CNP.I: AOS AT.CHS(T) ;NOT REALLY THE RIGHT THING, BUT CLOSE
JRST CZECHI
CNP.Z: SETZM AT.LNN(T) ;HOME DOWN (GO UP FROM TOP!)
CNP.U: MOVE D,FO.RPL(T) ;MOVE UP
SUBI D,1 ;WRAP AROUND FROM TOP TO BOTTOM
SOSGE AT.LNN(T) ; USING "REAL" PAGE LENGTH
MOVEM D,AT.LNN(T)
JRST CZECHI
CNP.V: HLRZ D,TT ;SET VERTICAL POSITION
SUBI D,7 ;IF TOO LARGE, PUT ON BOTTOM
CAMLE D,FO.RPL(T)
MOVE D,FO.RPL(T)
SUBI D,1
MOVEM D,AT.LNN(T)
JRST CZECHI
;;; VARIOUS ROUTINES FOR PRINTING ↑P CODES
CNPBBL: MOVEI D,"B
PUSHJ P,CNPCOD
CNPBL: MOVEI D,"B
PUSHJ P,CNPCOD
CNPL: MOVEI D,"L
JRST CNPCOD
CNPU: MOVEI D,"U
JRST CNPCOD
CNPF: MOVEI D,"F
JRST CNPCOD
CLRSRN: MOVEI D,"C
JRST CNPCOD
] ;END OF IFN ITS
IFN D20,[
WARN [TOPS-20 CLRSRN]
CLRSRN: POPJ P, ;PUNT THIS FOR NOW
] ;END IFN D20
;OPNTTY OPNT0 OPNT1 OPNT1A OPNT2 COPNT2
;;; ROUTINE FOR OPENING UP THE INITIAL TTY FILE ARRAYS.
;;; SKIPS ON SUCCESS (FAILS IF THIS JOB NEVER HAD THE TTY).
OPNTTY:
IFN ITS,[
.SUSET [.RTTY,,T] ;GET .TTY USER VARIABLE
TLNE T,%TBWAT ;IF SUPERIOR SET %TBWAT, IT CERTAINLY
JRST OPNT0 ; ANTICIPATES OUR OPENING TTY - LET'S OBLIGE
TLNE T,%TBNOT ;ELSE DON'T OPEN IF WE DON'T HAVE THE TTY
POPJ P,
OPNT0:
] ;END OF IFN ITS
20$ WARN [SHOULD WE NOT OPEN TTY IF DETACHED, OR CHECK .PRIIN?]
AOS (P)
HRRZ A,V%TYO
MOVEI TT,FO.EOP
PUSH P,@TTSAR(A)
PUSH P,[OPNT1] ;OPEN UP TTY OUTPUT ARRAY
PUSH P,A
MOVNI T,1
JRST $OPEN
OPNT1: MOVEI AR1,(A)
POP P,A
MOVEI TT,FO.EOP
MOVEM A,@TTSAR(AR1)
MOVEI TT,FO.LNL
MOVE TT,@TTSAR(AR1)
MOVEM TT,DLINEL ;SET UP DEFAULT LINEL FROM INITIAL JOB CONSOLE
MOVEI TT,FO.PGL
MOVE TT,@TTSAR(AR1)
MOVEM TT,DPAGEL ;SET UP DEFAULT PAGEL "
PUSH P,[OPNT1A]
PUSH P,AR1
MOVNI T,1
JRST STTYTYPE
OPNT1A: MOVEM A,VTTY ;INITIALIZE "TTY" TO (STATUS TTYTYPE)
HRRZ A,V%TYI
MOVEI TT,TI.BFN
PUSH P,@TTSAR(A)
IFN ITS+D20+SAIL,[
MOVEI TT,TI.ST1
PUSH FXP,@TTSAR(A)
MOVEI TT,TI.ST2
PUSH FXP,@TTSAR(A)
IFE ITS,[
MOVEI TT,TI.ST3
PUSH FXP,@TTSAR(A)
MOVEI TT,TI.ST4
PUSH FXP,@TTSAR(A)
] ;END OF IFE ITS
] ;END OF IFN ITS+D20+SAIL
PUSH P,COPNT2 ;OPEN UP TTY INPUT ARRAY
PUSH P,V%TYI
MOVNI T,1
JRST $OPEN
OPNT2:
IFN ITS+D20+SAIL,[
IT% POP FXP,T
IT% POP FXP,F
POP FXP,R ;BEWARE THE LOCKI WORD!
POP FXP,D
] ;END OF IFN ITS+D20+SAIL
LOCKI
MOVE TT,TTSAR(A)
POP P,TI.BFN(TT)
IFN ITS+D20+SAIL,[
MOVEM D,TI.ST1(TT)
MOVEM R,TI.ST2(TT)
IT% MOVEM F,TI.ST3(TT)
IT% MOVEM T,TI.ST4(TT)
IT$ .CALL TTY2ST
IT$ .LOSE 1400
SA$ MOVEI T,TI.ST1(TT)
SA$ SETACT T
IFN D20,[
HRRZ 1,F.JFN(TT)
MOVE 2,TI.ST1(TT)
MOVE 3,TI.ST2(TT)
SFCOC
HRRZ 1,F.JFN(TT)
RFMOD
IOR 2,TI.ST3(TT)
HRRZ 1,F.JFN(TT)
SFMOD
SETZB 2,3
] ;END OF IFN D20
] ;END OF IFN ITS+D20+SAIL
UNLOCKI
HRRZ A,V%TYI
HRRZ B,V%TYO
PUSHJ P,SSTTYCONS ;CONS THEM TOGETHER AS CONSOLE
COPNT2: POPJ P,OPNT2
;CLRIN CLRI3 CLRIN9
SUBTTL CLEAR-INPUT, CLEAR-OUTPUT
;;; (CLEAR-INPUT X) CLEARS ANY PENDING INPUT.
;;; CURRENTLY ONLY EFFECTIVE FOR TTY'S.
CLRIN: PUSH P,AR1 ;SUBR 1
MOVEI AR1,(A)
PUSHJ P,IFILOK ;MAKE SURE ARGUMENT IS AN INPUT FILE
TLNE TT,TTS.TY
PUSHJ FXP,CLRI3 ;IF A TTY, CLEAR ITS INPUT
JRST $OUT1
CLRI3:
IFN ITS,[
.CALL CLRIN9 ;RESET TTY INPUT AT ITS LEVEL
.LOSE 1400
] ;END OF IFN ITS
IFN D10,[
MOVE D,F.DEV(TT)
CAMN D,[SIXBIT \TTY\]
CLRBFI
] ;END OF IFN D10
IFN D20,[
PUSH P,A
HRRZ 1,F.JFN(TT)
CFIBF ;CLEAR FILE INPUT BUFFER
POP P,A
] ;END OF IFN D20
SETZM FI.BBC(TT) ;CLEAR BUFFERED-BACK CHARS
; SETZM FI.BBF(TT) ;CLEAR BUFFERED-BACK FORMS
POPJ FXP,
IFN ITS,[
CLRIN9: SETZ
SIXBIT \RESET\ ;RESET I/O CHANNEL
400000,,F.CHAN(TT) ;CHANNEL #
] ;END OF IFN ITS
;CLROUT CLRO3 CLRO4 CLRO4 RCPOS1
;;; (CLEAR-OUTPUT X) CLEARS ANY OUTPUT NOT ACTUALLY ON
;;; THE OUTPUT DEVICE YET. CURRENTLY ONLY EFFECTIVE FOR TTY'S.
CLROUT: PUSH P,AR1 ;SUBR 1
MOVEI AR1,(A)
PUSHJ P,OFILOK
TLNE TT,TTS<TY> ;SKIP IF TTY
PUSHJ FXP,CLRO3
JRST $OUT1
CLRO3:
IFN ITS,[
.CALL CLRIN9 ;RESET CHANNEL
.LOSE 1400
CLRO4: .CALL RCPOS1 ;RESET CHARPOS AND LINEL
.LOSE 1400
HLL T,F.MODE(TT)
TLNE T,FBT.EC
MOVE D,R ;FOR ECHO MODE, USE ECHO MODE CURSORPOS
HLRZM D,AT.LNN(TT)
HRRZM D,AT.CHS(TT)
] ;END OF IFN ITS
IFN D10,[
MOVE D,F.DEV(TT)
CAMN D,[SIXBIT \TTY\]
CLRBFO
] ;END OF IFN D10
IFN D20,[
PUSH P,A
HRRZ 1,F.JFN(TT)
CFOBF ;CLEAR FILE OUTPUT BUFFER
CAIA
CLRO4: PUSH P,A
PUSH P,B
HRRZ 1,F.JFN(TT)
RFPOS ;READ FILE POSITION
HLRZM 2,AT.LNN(TT) ;STORE LINENUM
HRRZM 2,AT.CHS(TT) ;STORE CHARPOS
POP P,B
POP P,A
] ;END OF IFN D20
10% PUSH FXP,T
10% TLNN T,FBT.CM ;IF BLOCK MODE, RESET
10% JSP D,FORCE6 ; LISP BUFFER POINTERS
10% POP FXP,T
POPJ FXP,
IFN ITS,[
RCPOS1: SETZ
SIXBIT \RCPOS\ ;READ CURSOR POSITION
,,F.CHAN(TT) ;CHANNEL #
2000,,D ;MAIN CURSOR POSITION
402000,,R ;ECHO CURSOR POSITION
] ;END OF IFN ITS
;TTYMOR TTYMO3 TTYMO1 TTYMO2 TTYMOZ
;;; STANDARD **MORE** PROCESSOR
TTYMOR: PUSHJ P,STTYCONS ;SUBR 1
JUMPE A,CPOPJ ;STTYCONS LEFT ARG IN AR1
PUSH P,AR1
PUSH P,A
SETZ A, ;RESET NOINTERRUPT STATUS
PUSHJ P,NOINTERRUPT ; SO INTERRUPT CHARS WILL TAKE EFFECT
HRRZ AR1,-1(P)
STRT AR1,[SIXBIT \####MORE####!\] ;# IS QUOTE CHAR
TTYMO3: PUSH P,[TTYMO1]
PUSH P,R70
PUSH P,-2(P)
MOVNI T,2
JRST TYIPEEK+1
TTYMO1: PUSH P,[TTYMO2]
PUSH P,-1(P)
MOVNI T,1
CAILE TT,40
CAIN TT,177
JRST %TYI+1 ;SWALLOW SPACE OR RUBOUT
POPI P,2
TTYMO2: CAIE TT,↑S ;DON'T IGNORE ↑S
CAIN TT,33 ;OR <ALT>
JRST TTYMOZ
CAIGE TT,40 ;COMPLETELY IGNORE CONTROL CHARS
JRST TTYMO3 ? SA$ WARN [SAIL TTYMOR?]
TTYMOZ: POPI P,1
POP P,AR1
IT% POPJ P,
IFN ITS,[
MOVE D,[10,,"H] ;GO TO BEGINNING OF LINE
PUSHJ P,CNPCOD
PUSHJ P,CNPL ;CLEAR TO END OF LINE
HRLI AR1,600000 ;FLAG TO TERPRI (THIS IS ACTUAL FILE ARRAY)
JRST TERP1 ;DO SEMI-INTERNAL TERPRI
] ;END OF IFN ITS
;STCREA STCREN STMASK STCRE4 STCRE5 STCRE6 STCRE3 STCRE2 SCREBS STCRE1 STKNOT STKNOL STCAL1 STCALL ISTCAL ISTCA0 ISTCSH ISTCA1 ISTCA2 STPRED STSTOR STGET STDISW STDIOB STDIS1 STDIS2 STSYSL STRSLN STGETD STGETU STGPNA STGFUN STGWOM STGWO1 STGWO2 STSTOD STSTOU STSTU1 STSPNA STSFUN STSWO1 STSWOM
IFN SFA,[
SUBTTL SFA FUNCTIONS (INTERNAL AND USER)
; (SFA-CREATE <old-sfa or sfa-function>
; <amount-of-local-user-storage>
; <printname>)
STCREA: SKOTT A,LS\SY
JRST STCRE1
;HERE TO CREATE A NEW SFA: SFA-FUNCTION IN A, LISP FIXNUM IN B
STCREN: SKOTT B,FX ;FIXNUM AS SECOND ARG?
JRST STCRE2 ;NOPE, ERROR
PUSH P,A
PUSH P,B
PUSH P,C
MOVE TT,(B) ;GET THE LENGTH OF THE USER AREA
ADDI TT,<SR.LEN*2>+1 ;TO INSURE GETTING ENOUGH HALFWORDS
LSH TT,-1 ;THEN CONVERT TO NUMBER OF WORDS
MOVSI A,-1 ;JUST NEED THE SAR
PUSHJ P,MKLSAR ;GET A GC-PROTECTED ARRAY
POP P,C
LOCKI ;GOING TO HACK WITH THE ARRAY
MOVE TT,TTSAR(A) ;POINTER TO THE ARRAY DATA AREA
POP P,B ;LENGTH OF THE USER DATA AREA
MOVE T,(B)
MOVEM T,SR.UDL(TT) ;REMEMBER LENGTH OF USER DATA
EXCH A,(P) ;RESTORE FUNCTION AND SAVE SAR ADR
HRLI A,(CALL 3,) ;A CALL FUNCTION GOES IN UN-MARKED-FROM SLOT
MOVEM A,SR.CAL(TT) ;STORE THE CALL INSTRUCTION
HRRZM A,SR.FUN(TT) ;STORE THE FUNCTION
HRRZM C,SR.PNA(TT) ;STORE THE PRINTNAME
ROT T,-1 ;LENGTH OF USER AREA IN T
SKIPGE T ;CONVERT INTO NUMBER OF WORDS NEEDED
ADDI T,1
ADDI T,SR.LEN-SR.FML ;NUMBER OF SYSTEM WORDS MARKED
MOVNI R,(T) ;NUMBER OF WORDS TO MARK
HRLZI R,(R) ;IN LEFT HALF
HRRI R,SR.FML(TT) ;POINTER TO FIRST MARKED LOCATION IN RH
HRRZ D,@(P) ;GET SAR
MOVEM R,-1(D) ;STORE GC MARKING AOBJN POINTER
HRLZI TT,AS.SFA ;TURN THE ARRAY INTO AN SFA
IORM TT,@(P) ;TURN ON SFA BIT IN THE SAR
UNLOCKI ;ALLOW INTERRUPTS AGAIN
;THE FOLLOWING CODE SIMULATES:
; (SFA-CALL <NEWLY-CREATED-SFA> 'WHICH-OPERATIONS NIL)
HRRZ A,(P) ;FIRST ARG TO SFA IS SFA-OBJCT ITSELF
MOVEI B,QWOP ;WHICH-OPERATIONS
SETZ C, ;NO THIRD ARG
MOVEI TT,SR.CAL ;CALL INSTRUCTION SLOT
XCT @TTSAR(A) ;DO CALL INDIRECTLY THROUGH TTSAR
JUMPE A,STCRE3 ;THE SFA CAN'T DO ANYTHING, BUT WHY WORRY...
SKOTT A,LS ;BETTER HAVE GOTTEN A LIST BACK
JRST SCREBS ;BAD SFA IF DIDN'T GET BACK A LIST!
STMASK: SETZ F, ;F ACCUMLATES KNOWN SYSTEM OPERATIONS MASK
STCRE4: MOVE R,[-STKNOL,,STKNOT] ;AOBJN POINTER OVER KNOWN OPERATIONS
HLRZ B,(A) ;CAR IS THE OPERATION
STCRE5: HRRZ T,(R) ;KNOWN OPERATIOON
CAIE T,(B) ;MATCH?
JRST STCRE6 ;NOPE, KEEP LOOPING
HRRZ T,R ;GET POINTER
HLLZ TT,(R) ;GET MASK
CAIL R,STKNOT+18. ;LEFT HALF VALUE?
MOVSS TT ;NOPE, ASSUMED WRONG
TDOA F,TT ;ACCUMLATE THIS OPERATION AND EXIT LOOP
STCRE6: AOBJN R,STCRE5 ;CONTINUE LOOPING UNTIL ALL LOOPED OUT
HRRZ A,(A) ;CDR DOWN THE WHICH-OPERATIONS LIST
JUMPN A,STCRE4 ;DON'T JUMP IF DON'T HAVE TO
STCRE3: POP P,A ;POINTER TO SAR
MOVEI TT,SR.WOM ;POINT TO KNOWN OPERATIONS MASK
MOVEM F,@TTSAR(A) ;STORE IN ARRAY
POPJ P, ;THEN RETURN SAR
STCRE2: EXCH B,A ;C(B) WAS NOT A FIXNUM
WTA [FIRST ARG MUST BE A FIXNUM -- SFA-CREATE!]
EXCH B,A
JRST STCREN
SCREBS: FAC [WAS RETURNED FROM WHICH-OPERATIONS BUT SHOULD HAVE BEEN A LIST -- SFA-CREATE!]
STCRE1: FAC [CALLED WITH SFA, NOT IMPLIMENTED -- SFA-CREATE!]
;SFA OPERATION/INTERNAL BIT CORRESPONDANCE TABLE
STKNOT:
;LH BITS
SO.OPN,,Q$OPEN
SO.CLO,,Q$CLOSE
SO.REN,,Q$RENAMEF
SO.DEL,,Q$DELETEF
SO.TRP,,Q%TERPRI
SO.PR1,,Q%PR1
SO.TYI,,Q%TYI
SO.UNT,,QUNTYI
SO.TIP,,QTYIPEEK
SO.IN,,Q$IN
SO.EOF,,QEOFFN
SO.TYO,,Q%TYO
SO.OUT,,Q$OUT
SO.FOU,,QFORCE
SO.RED,,QOREAD
SO.RDL,,Q%READLINE
SO.PRT,,Q%PRINT
SO.PRC,,Q%PRC
;RH BITS
SO.MOD,,QFILEMODE
SO.POS,,QFILEPOS
STKNOL==:.-STKNOT ;LENGTH OF TABLE
;;; (SFA-CALL <sfa-object> <operation> <extra-arg>)
STCAL1: WTA [SHOULD BE AN SFA OBJECT -- SFA-CALL!]
STCALL: SKOTT A,SA ;MUST BE AN ARRAY HEADER
JRST STCAL1
HRLZI TT,AS.SFA ;NOW CHECK FOR SFA-NESS
TDNN TT,ASAR(A)
JRST STCAL1 ;AN ARRAY BUT NOT A REAL SFA
MOVEI TT,SR.CAL
XCT @TTSAR(A) ;INVOKE THE SFA
POPJ P,
;INTERNAL SFA CALL, BIT INDICATNG OP IN T, SFA-OBJECT IN AR1,
; THIRD ARG TO SFA IN C. RETURNS VALUE OF SFA IN A. DESTORYS ALL
; ACS.
ISTCAL: JFFO T,ISTCA0 ;MUST HAVE ONE BIT SET
LERR [SIXBIT \+INTERNAL-SFA-CALL CALLED WITH NO OP IN T!\]
ISTCA0: HRRZ B,STKNOT(TT) ;GET SYMBOL REPRESENTING OPERATION
MOVEI A,(AR1) ;SFA GETS ITSELF AS FIRST ARG
MOVEI TT,SR.WOM ;CHECK FOR LEGAL OP -- USE WHICH OP MASK
TDNN T,@TTSAR(A) ;MAKE SURE THIS INTERNAL OP IS DOABLE
JRST ISTCA1
;ENTER HERE FOR 'SHORT' INTERNAL CALL PROTOCOL, A, B, AND C SET UP CORRECTLY
ISTCSH: MOVEI TT,SR.CAL ;EXECUTE THE CALL TO THE SFA
XCT @TTSAR(A)
POPJ P, ;RETURN TO CALLER WITH RESULT IN A
ISTCA1: PUSH P,[ISTCA2] ;RETURN ADDRESS
PUSH P,A ;LISTIFY IMPORTANT INFO
PUSH P,B
PUSH P,C
MOVNI T,3 ;3 ARGS
JRST LIST ;DO IT!
ISTCA2:
FAC [ATTEMPT TO INVOKE SFA ON AN UNSUPPORTED OPERATION -- +INTERNAL-SFA-CALL!]
;;; (SFAP <object>) RETURNS T IF <object> IS AN SFA, ELSE NIL
STPRED: JSP TT,AFOSP ;CHECK IF A FILE OR SFA
JRST FALSE ;NEITHER, RETURN NIL
JRST FALSE ;FILE, RETURN FALSE
JRST TRUE ;SFA, RETURN TRUE
;;; (SFA-GET <sfa-object> <fixnum or system-location-name>)
;;; (SFA-STORE <sfa-object> <fixnum or system-location-name> <new-value>)
STSTOR: SKIPA F,[STSTOD] ;SFA-STORE DISPATCH TABLE
STGET: MOVEI F,STGETD ;SFA-GET DISPATCH TABLE
SKIPA
STDISW: WTA [NOT AN SFA -- SFA-GET/SFA-STORE!]
JSP TT,AFOSP ;INSURE WE HAVE AN SFA, A ==> AR1
JRST STDISW ;NOT AN SFA
JRST STDISW ;A FILE-OBJECT, BUT STILL NOT AN SFA
SKOTT B,FX ;FIXNUM AS SECOND ARG?
JRST STDIS1 ;NOPE, MUST BE A SYSTEM-LOCATION NAME
MOVE R,(B) ;GET THE ACTUAL FIXNUM
MOVEI TT,SR.UDL ;CHECK AGAINST THE MAXIMUM VALUE
CAML R,@TTSAR(AR1) ;IN RANGE?
JRST STDIOB ;NOPE, GIVE OUT-OF-BOUNDS CALL
ROT R,-1 ;MAKE INTO AN OFFSET AND A FLAG BIT (RH/LH)
JRST @-1(F) ;GIVE USER LOCATION ACCESS RETURN
STDIOB: EXCH A,B ;GIVE AN OUT-OF-BOUNDS ERROR
FAC [USER-INDEX OUT-OF-BOUNDS -- SFA-GET/SFA-STORE!]
STDIS1: MOVE T,[-STRSLN,,0] ;FIND SYS-LOC THAT 2ND ARG IS EQ TO
STDIS2: CAME B,STSYSL(T) ;MATCH THIS ENTRY?
AOBJN T,STDIS2 ;NOPE, CONTINUE THE LOOP
ADDI T,(F) ;MAKE CORRECT TABLE ADDRESS
SKIPGE T ;BUT DID WE REALY FIND A MATCH?
JRST @(T) ;YES, SO DISPATCH
EXCH A,B
FAC [ILLEGAL SYSTEM-LOCATION NAME -- SFA-GET/SFA-STORE!]
;SFA SYSTEM-NAME TABLE
STSYSL: QFUNCTION ;FUNCTION
QWOP ;WHICH-OPERATIONS
QPNAME ;PNAME
STRSLN==:.-STSYSL
;SFA-GET DISPATCH TABLE AND FUNCTIONS
STGETU ;USER LOCATION
STGETD: STGFUN ;FUNCTION
STGWOM ;OPERATIONS MASK
STGPNA ;PRINT NAME
STGETU: MOVEI TT,SR.FUS(R) ;INDEX INTO ARRAY
HLRZ A,@TTSAR(AR1) ;TRY THE LEFT HALF
SKIPGE R ;BUT IS IT THE RIGHT HALF?
HRRZ A,@TTSAR(AR1) ;YUP, SO FETCH THAT
POPJ P, ;RETURN SLOT'S VALUE
STGPNA: SKIPA TT,[SR.PNA] ;RETURN THE PNAME
STGFUN: MOVEI TT,SR.FUN ;RETURN THE FUNCTION
HRRZ A,@TTSAR(AR1)
POPJ P,
STGWOM: MOVEI TT,SR.WOM ;RETURN THE WHICH-OPERATIONS MASK
MOVE D,@TTSAR(AR1) ;GET THE MACHINE NUMBER AND CONS UP A FIXNUM
SETZ A, ;START OFF WITH NIL
STGWO1: JFFO D,STGWO2 ;ANY MORE LEFT TO DO?
POPJ P, ;NOPE, RETURN WITH CONSED UP LIST IN A
STGWO2: HRRZ B,STKNOT(R) ;GET ATOM CORRESPONDING TO MASK BIT
JSP T,%XCONS ;ADD TO THE HEAD OF THE LIST
HRLZI T,400000 ;NOW TURN OFF THE BIT WE JUST HACKED
MOVNS R ;MUST NEGATE TO ROTATE
ROT T,(R) ;SHIFT INTO CORRECT BIT POSITION
TDZ D,T ;TURN OFF THE BIT
JRST STGWO1 ;AND DO THE REMAINING BITS
;SFA-STORE DISPATCH TABLE AND ROUTINES
STSTOU ;USER LOCATION
STSTOD: STSFUN ;FUNCTION
STSWOM ;OPERATIONS MASK
STSPNA ;PRINT NAME
STSTOU: MOVEI A,(C) ;PDLNMK THE THING WE ARE GOING TO STORE
JSP T,PDLNMK
MOVEI TT,SR.FUS(R) ;INDEX INTO ARRAY
JUMPL R,STSTU1 ;RIGHT HALF
HRLM A,@TTSAR(AR1) ;STORE IN THE LEFT HALF
POPJ P, ;RETURN SLOT'S VALUE
STSTU1: HRRM A,@TTSAR(AR1) ;LEFT HALF
POPJ P,
STSPNA: SKIPA TT,[SR.PNA] ;STORE THE PNAME
STSFUN: MOVEI TT,SR.FUN ;STORE THE FUNCTION
HRRZM C,@TTSAR(AR1)
MOVEI A,(C) ;RETURN THE STORED VALUE
CAIE TT,SR.FUN ;WERE WE HACKING THE FUNCTION?
POPJ P, ;NO, SO WE ARE DOINE
HRLI C,(CALL 3,) ;WE MUST ALSO FIX THE CALL INSTRUCTION
MOVEI TT,SR.CAL
MOVEM C,@TTSAR(AR1)
POPJ P,
STSWO1: EXCH A,C
WTA [MUST BE A LIST -- SFA-STORE (WHICH-OPERATIONS)!]
EXCH A,C
STSWOM: SKOTT C,LS ;IS THE ARGUMENT A LIST?
JRST STSWO1 ;NOPE, WRONG TYPE ARG ERROR
PUSH P,AR1 ;SAVE THE SFA FOR STMASK ROUTINE
MOVEI A,(C) ;EXPECTS WHICH-OPERATIONS LIST IN A
JRST STMASK ;THEN GENERATE A NEW MASK AND RETURN
] ;END IFN SFA
PGTOP QIO,[NEW I/O PACKAGE]
;
;;@ END OF QIO 585
;PIHOLD PINBL STDMSK DBGMSK STDMS2 DBGMS2 INTVEC TTYDF1 TTYDF2 LINTVEC
SUBTTL INTERRUPT HANDLERS
PGBOT INT
IFN ITS,[
PIHOLD: .SPICLR,,R70 ;WORD TO ".SUSET" TO TURN OFF INTERRUPT SYSTEM
PINBL: .SPICLR,,XC-1 ;WORD TO ".SUSET" TO TURN ON INTERRUPT SYSTEM
;;; NEW-STYLE INTERRUPT TRANSFER VECTOR
.SEE IMASK
;;; STANDARD VALUES TO PUT IN .MASK AND .MSK2 USER VARIABLES.
;;; INTERRUPTS NORMALLY ENABLED ARE:
;;; PARITY ERROR
;;; WRITE INTO READ-ONLY MEMORY
;;; MEMORY PROTECTION VIOLATION
;;; ILLEGAL OPERATION
;;; PDL OVERFLOW
;;; I/O CHANNEL ERROR
;;; RUN TIME CLOCK
;;; REAL TIME CLOCK
;;; ALSO, FOR THE USELESS SWITCH:
;;; CLI DEVICE INTERRUPT
;;; SYSTEM GOING DOWN/REVIVED
;;; SYSTEM BEING DEBUGGED
;;; CONTROL OF TTY JUST GIVEN BACK TO LISP
;;; (SSTATUS MAR) MAY ALSO ENABLE THE MAR INTERRUPT
.SEE SSMAR
STDMSK=%PIPAR+%PIWRO+%PIMPV+%PIILO+%PIPDL+%PIIOC+%PIRUN+%PIRLT
IFN USELESS, STDMSK=STDMSK+%PIDWN+%PIDBG+%PIATY
DBGMSK=STDMSK-<%PIPAR+%PIMPV+%PIILO+%PIATY>
;;; ALL I/O CHANNELS ARE ENABLED, AND ALL JOB CHANNELS FOR USELESS SWITCH.
STDMS2==177777
IFN JOBQIO, STDMS2==STDMS2+<377,,>
DBGMS2==STDMS2
DEFINE INTGRP HANDLER+PIRQC=0,IFPIR=0,DF1=STDMSK+%PIMAR-<%PIPDL+%PIPAR+%PIWRO+%PIMPV+%PIILO>,DF2=STDMS2
PIRQC
IFPIR
DF1
DF2
HANDLER
TERMIN
INTVEC: D←6+3,,INTPDL ;PDL FOR PUSHING INTERRUPT STUFF
;ACS D, R, F ARE SAVED ALONG WITH OTHER CRUD
INTGRP MEMERR,PIRQC=%PIPAR+%PIWRO+%PIMPV+%PIILO,DF1=STDMSK+%PIMAR-%PIPDL ;MEMORY AND OPCODE ERRORS
INTGRP PDLOV,PIRQC=%PIPDL ;PDL OVERFLOW
INTGRP IOCERR,PIRQC=%PIIOC ;I/O CHANNEL ERROR
IFN USELESS, INTGRP CLIINT,PIRQC=%PICLI ;CLI INTERRUPT
IFN USELESS, INTGRP TTRINT,PIRQC=%PIATY ;TTY RETURNED TO JOB
IFN USELESS, INTGRP SYSINT,PIRQC=%PIDWN+%PIDBG ;SYS DOWN OR BEING DEBUGGED
IFN JOBQIO, INTGRP JOBINT,IFPIR=[377,,] ;INFERIOR PROCEDURES
INTGRP CHNINT,IFPIR=177777 ;I/O CHANNEL INTERRUPTS
TTYDF1==:.-3 .SEE UINT0
TTYDF2==:.-2
IFN USELESS, INTGRP MARINT,PIRQC=%PIMAR ;MAR BREAK
INTGRP RUNCLOCK,PIRQC=%PIRUN ;RUNTIME ALARMCLOCK
INTGRP REALCLOCK,PIRQC=%PIRLT ;REAL TIME ALARMCLOCK
LINTVEC==:.-INTVEC ;LENGTH OF INTERRUPT VECTOR
;;; NOTE THE EFFECT OF HAVING THE ALARMCLOCKS LAST:
;;; IOC AND CHANNEL INTERRUPT HAPPEN FIRST, BUT WHEN
;;; THE PION HAPPENS INSIDE UINT0 THE ALARMCLOCK GETS
;;; ITS TURN IMMEDIATELY. FURTHERMORE, THE REAL TIME
;;; CLOCK GETS SLIGHTLY HIGHER PRECEDENCE.
] ;END OF IFN ITS
;DISMSK DISMSK STDMSK STDMSK STDMSK DBGMSK CHNTAB LEVTAB ENBINT ENBIN2 ENBIN1 REAINT DALINT DISINT DSMINT INTSUP $PDLOV INTNXP INTIRD INTMPV INTIWR INTILO INTMER INTASS ASSIN1 ASSRET
IFN D20,[
;;; TOPS-20 INTERRUPT HANDLER
;;; INTERRUPTS NOMRALLY ENABLED ARE:
;;; PDL OVERFLOW
;;; ILLEGAL INSTRUCTION
;;; ILLEGAL MEMORY READ
;;; ILLEGAL MEMORY WRITE
;;; NONEXISTANT PAGE REFERENCE
;;; VARIOUS CHARACTERS ENABLED FOR INTERRUPTS:
;;; ↑A, ↑B, ↑D, ↑E, ↑F, ↑G, ↑V, ↑W, ↑X, ↑Z
;;; CHANNEL ASSIGNMENTS:
;;; 1) PDL OV
;;; 2) ILLEGAL INSTRUCTION, ILL MEM R & W, OTHER SYNC INTERRUPTS
;;; 3) ASYNCHRONOUS INTERRUPTS
DISMSK==0 ;GENERATE IMPORTANT INTERRUPTS MASK
IRP FOO,,[.ICPOV,.ICILI,.ICIRD,.ICIWR,.ICNXP]
DISMSK==DISMSK+<1←<35.-FOO>>
TERMIN
STDMSK==DISMSK ;GENERATE STANDARD INTERRUPT MASK
IRP FOO,,[.ICDAE]
STDMSK==STDMSK+<1←<35.-FOO>>
TERMIN
STDMSK==STDMSK+<770000,,007777> ;ALSO INCLUDE ALL USER ASSIGNABLE CHANNELS
DBGMSK==STDMSK ;FOR NOW, MASKS ARE EQUIVALENT
;CHANNEL TABLE (ASSIGNS A PRIORITY LEVEL AND HANDLER ADR TO EACH CHANNEL)
CHNTAB:
REPEAT 6, 3,,INTASS+<.RPCNT*3> ;FIRST 6 ASSIGNABLE INTERRUPTS
0 ? 0 ? 0 ;ARITHMETIC OVERFLOWS
1,,$PDLOV ;PLDOV
0 ? 0 ;E-O-F AND DATA-ERROR
0 ? 0 ? 0 ;RESERVED TO DEC
2,,INTILO ;ILLEGAL INSTRUCTION
2,,INTIRD ;ILLEGAL MEMORY READ
2,,INTIWR ;ILLEGAL MEMORY WRITE
0 ? 0 ? 0 ? 0 ;RESERVED, AND ?
2,,INTNXP ;NON-EXISTANT PAGE
0 ; CHANNEL 23. LOSES!
REPEAT CINTSZ-6, 3,,INTASS+<6+.RPCNT>*3 ;REMAINING ASSIGNABLE INTERRUPTS
IFN .-CHNTAB-36., WARN [WRONG NUMBER ENTRIES IN CHNTAB?]
;LEVEL TABLE - WHERE TO STORE PC FOR INTERRUPT AT EACH PI LEVEL
LEVTAB: 0,,INTPC1
0,,INTPC2
0,,INTPC3
;;; TOPS-20 INTERRUPT HANDLING ROUTINES
;;; CALLED AT STARTUP TO REINITIALIZE THE INTERRUPT SYSTEM
ENBINT: MOVEI 1,.FHSLF ;MANIPULATE OURSELVES
MOVE 2,[LEVTAB,,CHNTAB] ;INTERRUPT PC STORAGE TAB,,CHANNEL LOC TAB
SIR ;SPECIFY THE TABLES
SETZ T, ;LOOP OVER AND ASSIGN TTY INTERRUPT CHANNELS
ENBIN2: SKIPG 1,CINTAB(T) ;THIS ENTRY USED FOR TTY INTERRUPT?
JRST ENBIN1 ;NOPE, GO ON
MOVSS 1 ;CHARACTER GOES IN LEFT HALF
HRRI 1,(T) ;CHANNEL IN RIGHT HALF
CAIL T,6 ;RELOCTAION NECESSARY?
ADDI 1,24.-6 ;YES, MAKE REAL CHANNEL NUMBER
ATI ;ASSIGN TERMINAL INTERRUPT CHANNEL
ENBIN1: CAIGE T,CINTSZ-1 ;DONE?
AOJA T,ENBIN2
MOVEI 1,.FHSLF ;ENABLE APPROPRIATE CHANNELS
MOVE 2,[STDMSK] ;ENABLE STANDARD INTERRUPTS
MOVEM 2,IMASK ;THIS IS CURRENT INTERRUPT MASK
MOVEM 2,OIMASK ;THIS IS ALSO THE OLD-MASK
AIC
MOVEI 1,.FHSLF ;ENABLE OUR INTERRUPT SYSTEM
XCTPRO
EIR
SETZB 1,2 ;DON'T LEAVE RANDOMNESS IN PROTECTED ACS
NOPRO
POPJ P,
;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT
REAINT: PUSH P,1
PUSH P,2
XCTPRO
AOSE INTALL ;DISABLED ALL INTS?
SKIPA 2,OIMASK ;NO, USE OLD INTERRUPT MASK
SKIPA 2,IMASK ;ELSE USE CURRENT MASK
MOVEM 2,IMASK ;THIS IS NOW THE CURRENT MASK
MOVEI 1,.FHSLF ;REENABLE INTERRUPTS FOR OURSELF
AIC
POP P,2
POP P,1
NOPRO
POPJ P,
;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING
;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE
; INTERRUPTS FROM IMASK RATHER THAN OIMASK
WARN [THINK ABOUT USING 'DIR' FOR DALINT]
DALINT: PUSH P,1
PUSH P,2
XCTPRO
MOVEI 1,.FHSLF ;DEFER ALL INTERRUPTS
SETO 2,
DIC
SETOM INTALL ;FLAG THAT ALL INTERRUPTS HAVE BEEN DISABLED
POP P,2
POP P,1
NOPRO
POPJ P,
;DISABLE ALL BUT IMPORTANT INTERRUPTS
;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE
DISINT: PUSH P,1 ;WE WILL NEED TWO WORKING ACS
PUSH P,2
XCTPRO
MOVE 2,IMASK ;GET CURRENT INTERRUPT MASK
MOVEM 2,OIMASK ;UPDATE OLD MASK
AND 2,[DISMSK] ;ONLY ALLOW IMPORTANT INTERRUPTS
MOVEM 2,IMASK ;NEW MASK
MOVEI 1,.FHSLF
AIC ;MAKE SURE THE IMPORTANT INTERRUPTS ARE ON
SETCA 2,
DIC ;BUT ONLY THE IMPORTANT INTERRUPTS
POP P,2
POP P,1
NOPRO
POPJ P,
;;; DISMISS AN INTERRUPT
DSMINT:
XCTPRO
AOS DSMSAV ;POINT TO NEXT FREE LOCATION (A SMALL STACK)
MOVEM 1,@DSMSAV ;SAVE AC 1
MOVEI 1,.FHSLF ;TURN OFF SYSTEM INTS WHILE MUNGING INTPDL
DIR
MOVE 1,INTPDL ;NOW UNDO INTPDL
POP 1,F
POP 1,R
POP 1,D
POP 1,@-1(1) ;RESTORE RETURN PC
SUB 1,R70+1 ;THROW AWAY RETURN PC POINTER
POP 1,IMASK ;RESTORE OLD IMASK
SUB 1,R70+2
MOVEM 1,INTPDL
MOVEI 1,.FHSLF
EIR ;NOW ALLOW INTERRUPTS
MOVEI 1,.FHSLF
AOS DSMSAV ;SAVE AC 2 ON TOP OF STACK
MOVEM 2,@DSMSAV
MOVE 2,IMASK ;TELL TOPS-20 ABOUT OLD IMASK
AIC
MOVE 2,@DSMSAV ;RESTORE AC'S
SOS DSMSAV
MOVE 1,@DSMSAV
SOS DSMSAV
NOPRO
DEBRK ;THEN DISMISS THE CURRENT INTERRUPT
;;; INTPDL BUILDER: RETURNS INTPDL IN F, ACCEPTS PC POINTER ON FLP
INTSUP:
XCTPRO ;NEED PROTECTION AS WE WILL USE MARKED ACS
MOVEM 1,SUPSAV ;SAVE NEEDED REGISTER
MOVEI 1,.FHSLF ;TURN OFF THE INTERRUPT SYSTEM WHILE TOUCHING
DIR ; INTPDL
MOVE 1,INTPDL
PUSH 1,NIL ;IPSWD1 AND IPSWD2
PUSH 1,NIL
PUSH 1,IMASK ;IMASK UPON ENTRY
PUSH 1,F ;SAVE THE PC POINTER
HRRZS (1) ;BUT ONLY RH
PUSH 1,(F) ;AND SAVE THE PC
PUSH 1,D ;SAVE PRESERVED ACS
PUSH 1,R
HLRZS F ;RH NOW HAS ADR OF F
PUSH 1,(F) ;SAVES F
MOVE F,1 ;COPY OF INTPDL TO F
MOVEM F,INTPDL ;SAVE INTPDL
MOVEI 1,.FHSLF ;REEANBLE INTERRUPTS
EIR
MOVE 1,SUPSAV
NOPRO
JRST (T) ;RETURN TO CALLER
;;; THE ACTUAL INTERRUPT HANDLERS
;PDL OVERFLOW
$PDLOV: MOVEM T,PDLSVT ;SAVE T SO THAT WE HAVE AN AC TO USE
MOVE T,INTPDL ;FUDGE INTPDL STACK FRAME
PUSH T,NIL ;IPSWD1 AND IPSWD2 UNUSED
PUSH T,NIL
PUSH T,IMASK ;SAVE IMASK UPON ENTRY
PUSH T,LEVTAB ;RH IS INTERRUPT PC ADR, @ AND () FIELDS OFF
PUSH T,@LEVTAB ;SAVE PC
PUSH T,D
PUSH T,R
PUSH T,F
MOVEM T,INTPDL ;STORE NEW INTPDL POINTER
MOVE T,PDLSVT ;RESTORE AC T
JRST PDLOV ;THEN PROCESS PDL OV
;;; PRIORITY LEVEL 2 INTERRUPT HANDLERS
;INTERRUPT AFTER NEWLY CREATED PAGE
INTNXP: MOVEM T,LV2SVT
MOVE T,@LEVTAB+1
HLRZ T,(T) ;GET THE INSTRUCTION THAT CAUSED THE GRIEF
TRZ T,000037 ;ANY INDEX OR INDIRECTION IS OK
CAIE T,(SETMM) ;SPECIAL WAY TO CREATE A PAGE, SO ALL IS OK
JRST INTMPV ;OTHERWISE IS BAD NEWS
MOVE T,LV2SVT ;ELSE RESTORE T
DEBRK ;AND RETURN INSTANTLY
;ILLEGAL MEMORY READ
INTIRD: MOVEM T,LV2SVT ;TREAT ILLEGAL MEMORY READ AS MPV
;HERE ON MEMORY PROTECTION VIOLATION, T SAVED ON FXP
INTMPV: MOVEI T,%PIMPV ;TURN INTO AN MPV
JRST INTMER ;AND TREAT LIKE OTHER MEMORY ERRORS
;ILLEGAL MEMORY WRITE
INTIWR: MOVEM T,LV2SVT
MOVSI T,(%PIWRO) ;WRITE INTO READ-ONLY MEMORY
JRST INTMER
;ILLEGAL OP
INTILO: MOVEM T,LV2SVT
MOVEI T,%PIILO ;ILLEGAL OPERATION
;COMMON MEMORY ERROR HANDLER, T IS PUSHED ON FXP AND CONTAINS THE ERROR BIT
;FUDGE INTPDL AND JRST OFF TO MEMERR
INTMER: MOVEM F,LV2SVF ;SAVE F IN KNOWN PLACE
MOVEM T,LV2ST2 ;ALSO SAVE FLAGS
MOVE F,[LV2SVF,,INTPC2] ;WHERE F IS,,WHERE PC IS
JSP T,INTSUP ;SETUP INTPDL, RETURN INTPDL IN F
MOVE T,LV2ST2 ;GET BACK FLAG BITS
MOVEM T,IPSWD1(F) ;STORE MEMORY ERROR BITS
MOVE T,LV2SVT ;RESTORE ACTUAL CONTENTS OF T
JRST MEMERR ;THEN PROCESS THE MEMORY ERROR
;;; ASSIGNABLE INTERRUPT HANDLER
INTASS:
REPEAT CINTSZ,[
MOVEM T,LV3SVT ;SAVE AC T
MOVEI T,.RPCNT ;INDEX INTO CINTAB
JRST ASSIN1 ;THEN USE COMMON CODE
]
ASSIN1: SKIPN CINTAB(T) ;ASSIGNED CHANNEL?
JRST ASSRET ;NOPE, RANDOM INTERRUPT; JUST RETURN
SKIPG CINTAB(T) ;'CHANNEL' INTERRUPT (A CHARACTER?)
HALT ;NO, SOME OTHER TYPE, BUT NONE SUPPORTED YET...
MOVEM F,LV3SVF
MOVE F,[LV3SVF,,INTPC3]
MOVEM T,LV3ST2 ;SAVE INTERRUPT TABLE INDEX
JSP T,INTSUP ;SETUP INTPDL
MOVE T,LV3ST2
HRRZ T,CINTAB(T) ;GET THE INTERRUPT CHARACTER
TRO T,400000 ;FLAG AS INTERNAL
MOVEM T,IPSWD2(F) ;STORE ON INTPDL
MOVE T,LV3SVT ;RESTORE ORIGIONAL CONTENTS OF T
JRST CHNINT ;THEN PROCESS THE CHANNEL INTERRUPT
ASSRET: MOVE T,LV3SVT ;RESTORE ORIGIONAL CONTENTS OF T
DEBRK ;THEN RETURN TO MAIN PROGRAM
] ;END IFN D20
;ENBINT REAINT REAIN1 DISINT DALINT INTRPT DSMINT INTERR PARINT NXMINT ILMINT SAIMER EYEINT SAIIMS SAIDSP
IFN SAIL,[
;SAIL NEWIO INTERRUPT CODE
;CALLED TO REINITIALIZE THE INTERRUPT SYSTEM
ENBINT: MOVEI T,INTRPT ;FLAGS,,INTERRUPT LOCATION
MOVEM T,.JBAPR ;LOCATION SO MONITOR KNOWS
SETZM INTALL ;DID A 'DALINT' LAST (ALL INTS ARE MASKED)
SETOB T,REEINT ;ALL INTERRUPTS INCLUDING REENTER
SETOM REENOP ;BUT MUST SET BOTH FLAGS
IWKMSK T ;ALL GET US OUT OF IWAIT
INTMSK T ;ALL ARE MASKED ON
MOVE T,[STDMSK] ;ENABLE STANDARD INTERRUPTS
MOVEM T,IMASK ;THIS IS CURRENT INTERRUPT MASK
MOVEM T,OIMASK ;THIS IS ALSO THE OLD-MASK
INTENB T, ;TELL OPERATING SYSTEM WHICH INTS TO GENERATE
MOVEI T,REETRP ;REENTER TRAP ADR
MOVEM T,.JBREN ;ALLOW REENTER AS MEANS OF IOC INTERRUPT
POPJ P,
;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT
REAINT: PUSH FXP,T
AOSE INTALL ;DISABLED ALL INTS?
SKIPA T,OIMASK ;NO, USE OLD INTERRUPT MASK
SKIPA T,IMASK ;ELSE USE CURRENT MASK
MOVEM T,IMASK ;THIS IS NOW THE CURRENT MASK
INTMSK T ;THEN UNMASK CORRECT SET OF INTERRUPTS
SKIPG REEINT
JRST REAIN1
MOVEI T,CPOPJ
MOVEM T,.JBOPC
POP FXP,T
JRST REETR1 ;FUDGE A REENTER IF ONE WAS REQUESTED
REAIN1: POP FXP,T
SETOM REEINT
POPJ P,
;DISABLE ALL BUT IMPORTANT INTERRUPTS
;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE
DISINT: PUSH FXP,T ;WE WILL NEED A WORKING AC
MOVE T,IMASK ;GET CURRENT INTERRUPT MASK
MOVEM T,OIMASK ;UPDATE OLD MASK
ANDCM T,[INTPAR\INTPOV\INTILM\INTNXM] ;ONLY ALLOW THESE INTERRUPTS
MOVEM T,IMASK ;NEW MASK
INTMSK T ;TELL OPERATING SYSTEM
SETZM REEINT ;ALSO DISALLOW REENTERS
POP FXP,T
POPJ P,
;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING
;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE
; INTERRUPTS FROM IMASK RATHER THAN OIMASK
DALINT: INTMSK R70 ;MASK OFF ALL INTERRUPTS
SETOM INTALL ;FLAG THAT ALL INTERRUPTS HAVE BEEN DISABLED
POPJ P,
;HERE TO PROCESS AN INTERRUPT
;OPERATING SYSTEM JUMPS TO HERE WITH ALL ACS SAVED AND SET UP WITH INTERRUPT
;STATUS; THE OBJECT IS TO SAVE INTERRUPT DEPENDANT DATA AND THEN REENABLE
;THE INTERRUPT SYSTEM AS SOON AS POSSIBLE....NOTE THAT THIS MUST DISABLE
;INTERRUPTS DEPENDING UPON WHICH ONE WAS GENERATED.
;--INTERRUPT-- --DISABLES--
;MEMORY ERROR ALL EXCEPT PDL OV
;<ESC>I <ESC>I AND REENTER
;PDL OV ALL EXCEPT MEMORY ERROR AND PDL OV
;CLOCK CLOCK
INTRPT:
MOVE B,.JBCNI ;BH
MOVE C,.JBTPC ;BH
TLNE C,10000 ;BH
MOVEM B,INTFOO ;BH
MOVE A,INTPDL ;DON'T WORRY ABOUT SPACEWAR BUTTONS
SETZM REENOP ;NO ↑C/REENTER TRAPS NOW
MOVE B,.JBCNI ;GET INTERRUPT
PUSH A,B ;SAVE INTERRUPT CONDITIONS
PUSH A,10 ;SAVE ARGUMENT TO INTERRUPT (FOR <ESC>I)
PUSH A,IMASK ;DEFERRED INTERRUPT MASK CURRENTLY ACTIVE
JFFO B,.+1 ;GET INTERRUPT NUMBER INTO AC B+1
PUSH A,B+1 ;STORE THIS ON INTPDL
PUSH A,.JBTPC ;SAVE ADR INTERRUPT EMANATES FROM
PUSH A,NIL ;SAVE DUMMY WORDS TO HOLD ACS D, R, F
PUSH A,NIL
PUSH A,NIL
SKIPL A ;IF WE'RE GOING TO DROP DEAD,
HALT .+1 ; MIGHT AS WELL DO IT NOW
MOVEM A,INTPDL ;THIS IS NEW INTERRUPT PDL POINTER
UWAIT ;UWAIT WILL RESTORE USER AC'S
EXCH F,INTPDL ;SAVE F, GET POINTER TO INTPDL
MOVEM D,IPSD(F) ;SAVE D
MOVEM R,IPSR(F) ;SAVE R
MOVEI R,(F) ;COPY INTPDL INTO R
EXCH F,INTPDL ;RESTORE STATE OF F AND INTPDL
MOVEM F,IPSF(R) ;THEN SAVE F
MOVE F,IPSDF2(R) ;GET BIT NUMBER
MOVE R,SAIIMS(F) ;THIS WILL BE NEW IMASK (F HAS INT NUMBER)
MOVEM R,IMASK
INTMSK R
DEBREAK ;NOW GO TO USER LEVEL BUT NOT TO USER PROGRAM
SETZM INTFOO ;BH
JRST @SAIDSP(F) ;DISPATCH ON INTERRUPT INDEX
;DISMISS AN INTERRUPT
DSMINT: PUSH FXP,T
MOVE T,INTPDL
MOVE F,IPSDF1(T) ;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME
MOVEM F,IMASK
INTMSK F
POP T,F
POP T,R
POP T,D
PUSH P,(T) ;RETURN PC
POPI T,5 ;THE SAILOR MAN
MOVEM T,INTPDL ;RESTORE INTPDL
POP FXP,T
SKIPL REEINT
HALT ;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS
;CODE IS NOT PAIRED CORRECTLY
; (DISINT[DALINT]/REAINT)
SKIPG REENOP
POPJ P,
MOVEM T,REESVT ;WE NEED AT LEAST ONE AC
MOVE T,INTPDL ;USE T AS THE INTPDL
ADD T,R70+10 ;WE MUST RESERVE THE SPACE WE WILL NEED
MOVEM T,INTPDL
SUB T,R70+5 ;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC
POP P,(T) ;PC IS THAT WHICH WE WILL POPJ TO
JRST REETR1
;INTERRUPT HANDLING ROUTINES (DISPATCHED TO VIA SAIDSP)
INTERR: OUTSTR [ASCIZ\AN ILLEGAL INTERRUPT HAS BEEN RECEIVED. THIS IS AN
INTERNAL LISP ERROR\]
HALT
PARINT: MOVSI R,(%PIPAR) ;FLAG THAT IS PARITY ERROR
JRST SAIMER
NXMINT: SKIPA R,[%PIMPV]
ILMINT: MOVSI R,(%PIWRO)
SAIMER: MOVE F,INTPDL ;INT PDL POINTER INTO F
MOVEM R,IPSWD1(F) ;STORE WHERE MEMERR CAN FIND BITS
JRST MEMERR ;PROCESS MEMORY ERROR
;HERE FOR <ESC>I INTERRUPT
EYEINT: MOVE F,INTPDL ;INT PDL POINTER INTO F
SETZB R,IPSWD2(F) ;FORCE EXTERNAL CALL
; MOVM R,IPSWD2(F) ;GET <ESC>I ARG (POSITIVE FORM ONLY)
; CAILE R,177 ;ONLY CHARACTERS UP TO 177 HAVE MEANING
; TDZA R,R ;FORCE R TO ZERO
; TLO R,400000 ;FLAG THAT THIS IS AN INTERNAL CALL
; MOVEM R,IPSWD2(F) ;RESTORE ARGUMENT TO CHNINT
CLRBFI
JRST CHNINT ;FUDGE THE CHANNEL INTERRUPT
;NEW INTERRUPT MASK BITS, INDEXED BY CURRENT INTERRUPT NUMBER
SAIIMS: 0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0 ;NOT CURRENTLY ENABLED AT ANY TIME
INTPOV ;PAR ERROR: ONLY ALLOW PDL OV
-INTCLK-1 ;CLOCK INT: ALLOW ALL OTHERS
0 ? 0 ? 0 ? 0 ;NOT USED, IMP INTERRUPTS
-<INTCLK\INTTTI>-1 ;<ESC>I: ALL EXCEPT <ESC>I AND CLOCK
0 ;CHANGING QUEUES, NOT USED
INTPOV\INTILM\INTNXM\INTPAR\INTPOV ;PDL OV: ALL MEMORY ERRS AND PDL OV
0 ;PDP-11 INT, NOT USED
INTPOV ;ILM: ONLY PDL OV
INTPOV ;NXM: ONLY PDL OV
0 ? 0 ? 0 ;OVERFLOW AND OLD CLOCK TICK
;DISPATCH TABLE, INDEXED BY INTERRUPT NUMBER
SAIDSP:
REPEAT 11,INTERR ;INTERRUPT ERROR, THIS CANNOT HAPPEN
PARINT ;PARITY ERROR
CLOCKI ;CLOCK INTERRUPT
INTERR ? INTERR ? INTERR ? INTERR ;VARIOUS IMP INTERRUPTS
EYEINT ;<ESC>I INTERRUPT
INTERR ? INTERR ? INTERR ;CHANGING QUEUES, UNUSED, UNUSED
PDLOV ;PDL OV
INTERR ? INTERR ;PDP-11 INTERRUPT, UNUSED
ILMINT ;ILL MEM REF
NXMINT ;NON-EXISTANT MEMORY
INTERR ? INTERR ? INTERR ;UNUSED, UNUSED, OLD CLOCK INT
INTERR ? INTERR ;UNUSED
INTERR ;FLOATING OVERFLOW
INTERR ? INTERR ;UNUSED
INTERR ;INTEGER OVERFLOW
REPEAT 4, INTERR ;UNUSED
] ;END IFN SAIL
;ENBINT REAINT REAIN2 REAIN1 DISINT DALINT APRTRP $PDLOV DSMINT UCHINT REETRP REETR1
IFN D10*<SAIL-1>,[
SUBTTL DEC-10 ONLY NEWIO INTERRUPT CODE
;***A NOTE OF CAUTION
;WHENEVER THE INTPDL IS TOUCHED, IT IS DONE SO IN A CERTAIN ORDER OF
;INSTRUCTIONS. THIS IS NECESSARY TO PREVENT TIMING ERRORS FROM SCREWING
;UP THE PDL SLOT ALLOCATION (THIS PREVENTS SAVED AC'S, FOR EXAMPLE, TO
;BE OVERWRITTEN BY NESTED INTERRUPTS). DO NOT CHANGE ANY ORDERING OF
;THIS CODE WITHOUT METICULOUS CHECKING TO SEE THAT RANDOM, ASYNCHRONOUS
;INTERRUPTS WILL NOT CAUSE TOTAL LOSSAGE.
;INTERRUPT ENABLING/DISABLING
;ENABLE NORMAL INTERRUPTS, CALLED AT STARTUP
ENBINT: MOVEI T,REETRP ;REENTER TRAP ADR
MOVEM T,.JBREN
MOVEI T,APRTRP ;THIS LOCATION FOR ALL APR TRAPS
MOVEM T,.JBAPR ;INFORM TOPS-10 VIA JOBDAT
MOVEI T,STDMSK
MOVEM T,IMASK ;THIS IS CURRENT INTERRUPT MASK
MOVEM T,OIMASK ;ALSO IS OLD INTERRUPT MASK
SETOM REEINT ;REENTER INTERRUPTS ARE OK
SETOM REENOP ;BUT MUST SET BOTH FLAGS
SETZM INTALL ;WE HAVEN'T DISABLED ALL INTERRUPTS
APRENB T,
POPJ P, ;NO OTHER TRAPS VIA THIS MECHANISM
;RE-ENABLE AFTER DISABLE INTERRUPTS
REAINT: PUSH FXP,T
AOSE INTALL ;DISABLED ALL INTS?
SKIPA T,OIMASK ;NO, USE OLD INTERRUPT MASK
SKIPA T,IMASK ;ELSE USE CURRENT MASK
MOVEM T,IMASK ;THIS IS NOW THE CURRENT MASK
APRENB T,
SKIPLE REENOP
JRST REAIN2
SKIPG REEINT
JRST REAIN1
REAIN2: MOVEI T,CPOPJ
MOVEM T,.JBOPC
POP FXP,T
JRST REETR1 ;FUDGE A REENTER IF ONE WAS REQUESTED
REAIN1: SETOM REEINT
SETOM REENOP
POP FXP,T
POPJ P,
;DISABLE ALL BUT IMPORTANT INTERRUPTS
DISINT: PUSH FXP,T
MOVE T,IMASK ;GET CURRENT MASK
MOVEM T,OIMASK ;REMEMBER IT FOR RESETING PURPOSES
ANDI T,AP.POV ;ONLY ALLOW IMPORTANT INTERRUPTS
MOVEM T,IMASK ;THIS IS CURRENT STATE OF SYSTEM
SETZM REEINT ;NO REENTER'S NOW
APRENB T,
POP FXP,T
POPJ P,
;DISABLE ALL INTERRUPTS
DALINT: PUSH FXP,T
SETOM INTALL ;HAVE DISABLED ALL INTERRUPTS
SETZB T,REEINT
APRENB T,
POP FXP,T
POPJ P,
;APR TRAP HANDLING
APRTRP: SETZM REENOP ;ABSOLUTLY NO ↑C/REENTER INTERRUPTS NOW!
MOVEM T,APRSVT
SETZ T,
APRENB T, ;NO INTERRUPTS DURING TRAP SETUP
MOVE T,INTPDL ;USE T AS THE INTPDL
REPEAT 4, PUSH T, ;2 INTERRUPT WORDS AND 2 DEFFERED WORDS
PUSH T,.JBTPC ;INTERRUPT PC
PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO
PUSH T,R
PUSH T,F
MOVEM T,INTPDL
MOVE D,IMASK ;THIS IS GOING TO GO IN INT MASK1 WORD
MOVEM D,IPSDF1(T)
SETZ D,
MOVE F,.JBCNI ;GET ACTUAL PROCESSOR BITS
TRNE F,AP.PAR
TLO D,(%PIPAR) ;PARITY ERROR
TRNE F,AP.POV ;PDL OV?
JRST $PDLOV
TRNE F,AP.ILM ;PURE PAGE ERROR? (SHOULD THIS BE MPV?)
TLO D,(%PIWRO)
TRNE F,AP.NXM ;NON-EXISTANT MEMORY
TRO D,%PIMPV
MOVEM D,IPSWD1(T)
MOVE T,APRSVT
JUMPN D,MEMERR
OUTSTR [ASCIZ \UNRECOGNIZED APR INTERRUPT\]
HALT
$PDLOV: MOVE T,APRSVT
JRST PDLOV
;DISMISS AN INTERRUPT
DSMINT: PUSH FXP,T
MOVE T,INTPDL
MOVE F,IPSDF1(T) ;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME
MOVEM F,IMASK
APRENB F,
POP T,F
POP T,R
POP T,D
PUSH P,(T) ;RETURN PC
POPI T,5
MOVEM T,INTPDL ;RESTORE INTPDL
POP FXP,T
SKIPL REEINT
HALT ;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS
;CODE IS NOT PAIRED CORRECTLY (DISINT[DALINT]/REAINT)
SKIPG REENOP
POPJ P,
MOVEM T,REESVT ;WE NEED AT LEAST ONE AC
MOVE T,INTPDL ;USE T AS THE INTPDL
ADD T,R70+10 ;WE MUST RESERVE THE SPACE WE WILL NEED
MOVEM T,INTPDL
SUB T,R70+5 ;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC
POP P,(T) ;PC IS THAT WHICH WE WILL POPJ TO
JRST REETR1
];END IFN D10*<SAIL-1>
;THE FOLLOWING CODE IS FOR TOPS-10 AND SAIL
IFN D10,[
;HERE FOR A USER CHARACTER INTERRUPT, MAKE AN INTSTACK FRAME AND CALL CHNINT
UCHINT: SETZM REEINT ;DON'T ALLOW ↑C/REENTERS TO GO THROUGH
MOVEM T,REESVT ;WE NEED AT LEAST ONE AC
MOVE T,INTPDL ;USE T AS THE INTPDL
ADD T,R70+10 ;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT
;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS
MOVEM T,INTPDL
SUB T,R70+4 ;WE WILL KEEP A DUMMY FOUR WORDS
PUSH T,[0,,CPOPJ] ;PC FLAGS 0 AS THEY MAY GET RESTORED BY JRST 2,
PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO
PUSH T,R
PUSH T,F
MOVEM D,IPSWD2(T)
MOVE D,IMASK ;PUT OLD IMASK IN WORD 1 MASK
MOVEM D,IPSDF1(T)
MOVE T,REESVT
SETOM REENOP
SETOM REEINT
JRST CHNINT
;REENTER TRAP ADR
REETRP: AOSG REENOP
AOSLE REEINT ;REENTER ALLOWED?
JRSTF @.JBOPC ;NOPE, FLAG AND GO ON
MOVEM T,REESVT ;WE NEED AT LEAST ONE AC
MOVE T,INTPDL ;USE T AS THE INTPDL
ADD T,R70+10 ;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT
;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS
MOVEM T,INTPDL
SUB T,R70+4 ;WE WILL KEEP A DUMMY FOUR WORDS
PUSH T,.JBOPC ;INTERRUPT PC
REETR1: PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO
PUSH T,R
PUSH T,F
SETZM IPSWD2(T) ;FORCE MASK TO ZERO AS IS USED SPECIALLY
MOVE D,IMASK ;STORE IMASK AS WORD1 MASK
MOVEM D,IPSDF1(T)
MOVE T,REESVT
SETOM REENOP
SETOM REEINT
JRST CHNINT
] ;END IFN D10
;INTXIT INTXT2 INTXT9 INTLOS INTLS1 INTLS9 XUINT XUINT9
;;; WHEN THE INTERRUPT OCCURS, ACS D, R, AND F HAVE BEEN SAVED.
;;; BY CONVENTION AN INTERRUPT HANDLER MOVES THE INTPDL POINTER
;;; INTO F, GETS A VALID FXP POINTER INTO FXP, AND PUSHES THE OLD
;;; CONTENTS OF FXP ONTO THAT PDL.
;;; STANDARD INTERRUPT EXIT
;;; WILL RESTORE FXP AND D+R+F, AND DISMISS THE INTERRUPT.
INTXIT: MOVE FXP,(FXP) ;POP FXP,FXP
SKIPN NOQUIT ;CHECK FOR USER INTS STACKED BY INT HANDLER
SKIPN INTFLG .SEE CHECKI
JRST INTXT2
SKIPE GCFXP ;HOW CAN GCFXP BE NON-ZERO WITH NOQUIT ZERO?
.LOSE
PUSH FXP,IPSD(F) ;ARRANGE TO RESTORE D AND THE PC
PUSH P,IPSPC(F) ; (INCLUDING FLAGS!) AFTER CHECKING
PUSH P,CPXDFLJ ; FOR STACKED INTERRUPTS
MOVEI R,CKI0
MOVEM R,IPSPC(F)
INTXT2:
IFN D20+D10, JRST DSMINT ;DISMISS THE INTERRUPT
IFN ITS,[.CALL INTXT9 ;RETURN PC IS ON TOP OF INTPDL,
.LOSE 1000 ; AND ALSO THE OLD DEFER WORDS
INTXT9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,D←6+3 ;POP ACS D, R, AND F FIRST
400000,,INTPDL ;INTERRUPT STACK POINTER
] ;END IFN ITS
;;; STANDARD LOSING INTERRUPT EXIT
;;; RESTORES FXP, AND D+R+F AS INTXIT DOES.
;;; ALSO EXPECTS A .LOSE ERROR CODE IN R.
INTLOS: MOVE FXP,(FXP) ;POP FXP,FXP
INTLS1:
IFN D10+D20, JRST DSMINT ;DISMISS THE INTERRUPT
IFN ITS,[.CALL INTLS9
.LOSE 1000
INTLS9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,D←6+3 ;POP ACS D, R, AND F FIRST
,,INTPDL ;INTERRUPT STACK POINTER
,,IPSPC(F) ;NEW PC ;IN ORDER TO SPECIFY
,,IPSDF1(F) ;NEW .DF1 ; THE .LOSE CODE, ONE
,,IPSDF2(F) ;NEW .DF2 ; MUST MENTION ALL THIS TOO
400000,,R ;.LOSE ERROR CODE
] ;END IFN ITS
;;; EXIT INTERRUPT, GOING TO USER INTERRUPT HANDLER.
;;; ARGUMENT FOR THE UINT ROUTINE IS IN D.
;;; PDLS ARE IN GOOD SHAPE BY NOW, OF COURSE.
XUINT: SKIPE GCFXP ;BE EXTRA SURE ABOUT THE
IT$ .LOSE ; GOODNESS OF THE PDLS!
IFN <D10+D20>, HALT
;;;; POP FXP,FXP ;AT THIS POINT SHOULD BE SAME AS SUB FXP,R70+1
MOVE FXP,(FXP)
PUSH P,IPSPC(F) ;PUSH INTERRUPT PC ON STACK FOR UINT
PUSH P,CPXDFLJ ;ARRANGE FOR AC D AND FLAGS TO BE RESTORED
PUSH FXP,IPSD(F) ;PUSH AC D (BEFORE INTERRUPT) ON FXP
MOVEM D,IPSD(F) ;CAUSE D TO SURVIVE THE DISMIS
IFN D10+D20,[
MOVEI D,UINT ;NEW PC
MOVEM D,IPSPC(F) ;STORE WHERE OLD PC WENT
JRST DSMINT ;THEN DISMISS THE INTERRUPT
] ;END IFN D10+D20
IFN ITS,[.CALL XUINT9
.LOSE 1000
XUINT9: SETZ
SIXBIT \DISMIS\ ;DISMISS INTERRUPT
5000,,D←6+3 ;POP ACS D, R, AND F FIRST
,,INTPDL ;INTERRUPT STACK POINTER
1000,,UINT ;NEW PC
,,TTYDF1 ;NEW .DF1
400000,,TTYDF2 ;NEW .DF2
] ;END IFN ITS
;MEMERR MPVERR PURERR ILOPER ILOPR1 PARERR MEMER5 MEMER7 MEMER8 UIMPAR UIMILO UIMWRO UIMMPV $XLOST $XLOSE MEMER8 UIMPAR UIMILO UIMWRO UIMMPV
;;; MEMORY AND OPCODE ERRORS: PARITY, PURE, MPV, ILOP.
;;; ASSUME NO MORE THAN ONE HAPPENS AT A TIME.
MEMERR:
IT$ .SUSET [.RJPC,,JPCSAV]
MOVE F,INTPDL
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
MOVN R,IPSWD1(F) ;THIS SEQUENCE KILLS THE LOW-ORDER
ANDCA R,IPSWD1(F) ; BIT FROM THE INTERRUPT WORD
; FOR D10, WILL CONTAIN APR FLAGS OF MERIT
SKIPE R ;LOSE IF MORE THAN ONE BIT WAS SET
IT$ .LOSE
IFN D10+D20, HALT
MOVE R,IPSWD1(F)
HRRZ D,IPSPC(F)
IT$ CAIN D,THIRTY+5 ;DDT DOES ≠X IN LOCATION 34
IT$ JRST $XLOSE
TLNE R,(%PI<PAR>) ;WAS IT A PARITY ERROR?
JRST PARERR
TLNE R,(%PI<WRO>) ;WRITE INTO READ-ONLY?
JRST PURPGI
TRNE R,%PI<ILO> ;ILLEGAL OPERATION?
JRST ILOPER
TRNN R,%PI<MPV> ;MEMORY PROTECT VIOLATION?
.VALUE ;NO??? WHAT HAPPENED???
CAIE D,UBD1 ;LET SPECPDL RESTORATION HAPPEN
JRST MPVERR ; EVEN IF ONE SLOT GOT CLOBBERED
AOS IPSPC(F) ;BUMP PC PAST OFFENDING INSTRUCTION
JRST INTXIT
MPVERR: SKIPA D,[UIMMPV]
PURERR: MOVEI D,UIMWRO
JRST MEMER5
ILOPER:
IFN D20,[
SKIPN TENEXP
JRST ILOPR1
; THIS A CRUFTY BUT ADEQUATE THEORY OF ERJUMPS
HRLZ R,0(D)
CAIE R,320700 ;ERJUMP?
JRST ILOPR1
HRLZ R,-1(D)
CAIE R,104000 ;JSYS?
JRST ILOPR1
HRRZ R,0(D)
HRRM R,IPSPC(F) ;CLOBBER RESTART ADDRESS
JRST INTXIT
ILOPR1:
] ;END IFN D20
SKIPA D,[UIMILO]
PARERR: MOVEI D,UIMPAR
MEMER5: HRRZ R,INTPDL ;MACHINE ERROR! WHAT TO DO?
CAIN R,INTPDL+LIPSAV ;IF THE ERROR HAPPENED WITHIN AN INTERRUPT SERVER,
SKIPN VMERR ; OR IF USER SUPPLIED NO ERROR FUNCTION,
JRST MEMER7 ; CRAP OUT BACK TO DDT
MOVEI D,100000(D)
HRL D,IPSPC(F)
PUSHJ FXP,$IWAIT
JRST XUINT ;CALL USER INTERRUPT HANDLER
; JRST INTXIT ;MAY RE-DO LOSING INSTR, BUT SO WHAT?
; THAT'S A FEATURE, NOT A BUG.
ANDI D,777
MEMER7:
IFN ITS,[
HRRZ R,MEMER8(D)
JRST INTLOS
MEMER8:
OFFSET -.
UIMPAR:: 1+.LZ %PIPAR
UIMILO:: 1+.LZ %PIILO
UIMWRO:: 1+.LZ %PIWRO
UIMMPV:: 1+.LZ %PIMPV
OFFSET 0
$XLOST: .VALUE [ASCIZ \:≠ YOUR ≠↔≠⊗X LOST ≠↔PROCEED⊗ \]
JRST THIRTY+5 ;LET THE ≠X RETURN CORRECTLY
$XLOSE: MOVEI R,$XLOST ;CAUSE INTERRUPT DURING AN ≠X
MOVEM R,IPSPC(F) ; TO GO TO $XLOST (CROCK)
JRST INTXIT
] ;END IFN ITS
IFE ITS,[
MOVEI A,MEMER8(D) ;TRANSFER TO ONE OF THE LER3'S BELOW
EXCH A,IPSPC(F)
ANDI A,-1
JRST INTXIT
MEMER8:
OFFSET -.
UIMPAR:: LER3 [SIXBIT \PC AT WHICH MEMORY PARITY ERROR OCCURRED!\]
UIMILO:: LER3 [SIXBIT \PC WITH ILLEGAL INSTRUCTION CODE!\]
UIMWRO:: LER3 [SIXBIT \PC AT WHICH ATTEMPT TO WRITE INTO PURE PAGE!\]
UIMMPV:: LER3 [SIXBIT \PC WITH MEMORY PROTECTION VIOLATION!\]
OFFSET 0
] ;END OF IFE ITS
;;; IFN D10,[
;;; OUTSTR @MEMER8(D) ;GIVE ERROR IF USER DOESN'T WANT IT
;;; EXIT 1,
;;; JRST .-2
;;; ] ;END IFN D10
;;;
;;; IFN D20,[
;;; HRRO 1,MEMER8(D) ;GIVE ERROR
;;; PSOUT
;;; HALTF ;THEN STOP EXECUTION NICELY
;;; ] ;END IFN D20
;;;
;;; IFN D10+D20,[
;;; MEMER8:
;;; OFFSET -.
;;; UIMPAR::[ASCIZ \?Parity error in job
;;; \]
;;; UIMILO::[ASCIZ \?Illegal op executed
;;; \]
;;; UIMWRO::[ASCIZ \?Write into read-only memory
;;; \]
;;; UIMMPV::[ASCIZ \?Memory protection violation
;;; \]
;;; OFFSET 0
;;; ] ;END IFN D10+D20
;IOCERR IOCERA IOCER8 IOCER9
IFN ITS,[
;;; I/O CHANNEL ERROR HANDLER
IOCERR: MOVE F,INTPDL
MOVE R,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,R
.SUSET [.RBCHN,,R]
SKIPN R
JRST IOCER8
.CALL SCSTAT
.LOSE 1400
LSH D,-33
HRRZ R,IPSPC(F)
MACROLOOP NIOCTR,ZZI,* ;ZZI MACROS DEFINE IOC TRAPS
SKIPL R
JRST IOCER8
IOCERA: HRRM R,IPSPC(F) ;CLOBBER RETURN PC
HLRZ R,R
CAIN R,400000+D ;WANT TO STICK IOC ERROR
MOVEI R,400000+IPSD(F) ; CODE INTO SPECIFIED AC,
CAIN R,400000+R ; BUT MUST BEWARE OF D AND R
MOVEI R,400000+IPSR(F)
MOVEM D,-400000(R)
JRST INTXIT
IOCER8: SKIPN IOCINS ;ANY USER IOC ERROR HANDLER?
JRST IOCER9 ;NOPE, LET DUPERIOR HAVE THE ERROR
MOVE R,IPSPC(F) ;PC IN R
;ERROR CODE IN D (SEE ABOVE)
;CALL USER WITH PC IN R AND ERROR CODE IN D.
;THE USER'S ROUTINE MUST NOT MUNG ANY AC'S OTHER THAN R AND D, THOUGH THE
;STACKS MAY BE USED. IF THE USER'S INSTRUCTION SKIPS, THE RIGHT
;HALF OF R CONTAINS THE PC TO DISPATCH TO AFTER THE DISMIS, AND THE LEFT HALF
;OF R CONTAINS 400000+<ADR IN WHICH TO STORE ERROR CODE>
PUSHJ FLP,@IOCINS
SKIPA
JRST IOCERA
IOCER9: MOVEI R,1+.LZ %PIIOC
JRST INTLOS
] ;END IFN ITS
;CHNINT CHNI1H CHNIZ TTYI1 CHNI2
;;; INTERRUPT FROM I/O CHANNEL.
;;; PRESENTLY ONLY TWO KINDS ARE HANDLED:
;;; TTY INPUT: INTERRUPT CHAR TYPED.
;;; TTY OUTPUT: **MORE**.
CHNINT: MOVE F,INTPDL
MOVE D,IPSWD2(F) ;GET WORD TWO INTERRUPT BITS
MOVE R,FXP ;FXP MAY BE IN A BAD STATE IF
SKIPE GCFXP ; WITHIN GC, SO RESTORE IT AND
MOVE FXP,GCFXP ; THEN PUSH ITS OLD VALUE
PUSH FXP,R ;REMEMBER, PDL OVERFLOW ISN'T DEFERRED NOW
IFN ITS,[
MOVN R,D
AND R,D ;R GETS LOWEST SET BIT
ANDCM D,R ;D GETS ALL OTHER BITS
SKIPE D
.SUSET [.SIIFPIR,,D] ;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED)
MOVE D,R
JFFO D,.+1 ;FIND CHANNEL NUMBER
MOVNS R ; FOR SOME PENDING
ADDI R,43 ; INTERRUPT BIT
PUSH FXP,R ;SAVE CHANNEL NUMBER
SKIPN R ;CHANNEL 0 ??
JRST CHNI2 ;YES, THIS CAN HAPPEN IN STRANGE CASES
SKIPN CHNTB(R) ;UNOPEN DEVICE ??
.VALUE ;BUT DON'T ALLOW INTERRUPTS FROM CLOSED CHAN
CHNI1H: .CALL SCSTAT ;GET STATUS FOR THE CHANNEL
.VALUE
ANDI D,77 ;GET ITS INTERNAL PHYSICAL DEVICE TYPE
SKIPE D
CAILE D,2
JRST CHNI5
];END IFN ITS
IFN D10+D20,[
MOVE R,D
PUSH FXP,V%TYI ;SAR ADR ON STACK
] ;END IFN D10+D20
IFN ITS,[
HRRZ D,CHNTB(R)
MOVE D,TTSAR(D)
TLNE D,TTS<IO>
JRST CHNI5
.ITYIC R, ;TYPE 0 IS TTY INPUT
JRST CHNI8 ;TIMING ERROR OR SOMETHING - IGNORE
] ;END IFN ITS
IFN D10,[
TRNE R,400000 ;IF NOT INTERNAL GET FROM USE
JRST CHNIZ ;ELSE WE HAVE ALREADY
OUTCHR ["?]
INCHRW R
SA$ TRO R,%TXCTL ;CONTROLLIFY THE CHARACTER
CHNIZ:
] ;END IFN D10
SA% IFN D10+D20, ANDI R,37 ;MAP ALL CHARS INTO CTRL CHARACTERS
SA$ ANDI R,777
PUSH FXP,R ;SAVE INTERRUPT CHARACTER
PUSH FXP,TT ; AND ALSO TT
HRRZ TT,-2(FXP) ;FETCH CHANNEL NUMBER
;FOR D-10, THIS IS ADR OF SAR
TTYI1:
IT$ HRRZ TT,CHNTB(TT)
HRRZ TT,TTSAR(TT)
IFN D10+D20,[
HRL TT,F.CHAN(TT) ;NOW GET CHANNEL #
HLRZM TT,-2(FXP) ;MAKE THE CHANNEL NUMBER CORRECT ON THE STACK
] ;END IFN D10+D20
JSP D,TTYICH ;GET BACK INTERRUPT FN IN R
POP FXP,TT
JUMPE R,CHNI2 ;NULL FUNCTION - IGNORE
MOVEI D,(R)
LSH D,-SEGLOG
MOVE D,ST(D)
TLNN D,FX
JRST CHNI4
MOVE R,(R) ;"FUNCTION" IS A FIXNUM
IFN ITS+SAIL,[
MOVEI D,(R) ;IF ANY OF THE SUPRA-ASCII
ANDCM D,(FXP) ; MODIFIER BITS ARE SET IN THE
MOVSS (FXP) ; "FUNCTION", INSIST THAT THE
ANDM R,(FXP) ; CORRESPONDING BITS APPEAR IN
MOVSS (FXP) ; THE CHARACTER TYPED. SIMILARLY,
IOR D,(FXP) ; THE SAME BITS SET IN THE LEFT HALF
TRNE D,%TX<MTA+CTL+TOP+SFT+SFL> ; MEAN THAT THOSE BITS MUST BE OFF.
JRST CHNI2
] ;END IFN ITS+SAIL
ANDI R,177
MOVEI D,TRUTH ;MOOOOBY SKIP CHAIN OF SYSTEM INTS
CAIN R,↑A ;↑A (SETQ ↑A T)
HRRZM D,SIGNAL
CAIN R,↑C ;↑C (SETQ ↑D NIL)
SETZM GCGAGV
CAIN R,↑D ;↑D (SETQ ↑D T)
HRRZM D,GCGAGV
CAIN R,↑G ;↑G (↑G) ;QUIT
JRST CN.G
CAIN R,↑R ;↑R (SETQ ↑R T)
HRRZM D,TAPWRT
CAIN R,↑T ;↑T (SETQ ↑R NIL)
SETZM TAPWRT
CAIN R,↑V ;↑V (SETQ ↑W NIL)
SETZM TTYOFF
CAIN R,↑W ;↑W (PROG2 (SETQ ↑W T)
JRST CN.W ; (CLEAR-OUTPUT T))
CAIN R,↑X ;↑X (ERROR 'QUIT) ;↑X QUIT
JRST CN.X
CAIN R,↑Z ;↑Z CRAP OUT TO DDT
JRST CN.Z
CHNI2: SUB FXP,R70+2
JRST INTXIT
;CHNI4 CHNI4A CHNI5 CHNI8 CHNI4C CHNI4H
CHNI4: POP FXP,D ;REAL LIVE USER INTERRUPT FUNCTION
TRO D,400000 ;2.9 => TTY INPUT INTERRUPT CHAR
CHNI4A: POP FXP,R
HRL D,CHNTB(R)
SKIPE UNREAL
JSP R,CHNI4C ;BARF! (NOINTERRUPT 'TTY) OR (NOINTERRUPT T)
PUSHJ FXP,$IWAIT ;CALLS UISTAK AND SKIPS IF IN GC
JRST XUINT ;RUNS USER INTERRUPT
JRST INTXIT
IFN ITS,[
CHNI5: HRRZ D,CHNTB(R) ;CHECK OUT FILE ARRAY
HRRZ D,TTSAR(D)
SKIPN FO.EOP(D) ;SKIP IF ENDPAGEFN
JRST CHNI8
MOVEI D,200000+<2*FO.EOP+1> ;2.8 => RANDOM FILE INTERRUPT
JRST CHNI4A ;**MORE** => ENDPAGEFN GETS RUN
CHNI8: SUB FXP,R70+1
JRST INTXIT
];END IFN ITS
;;; ROUTINE TO STACK UP INTERRUPT IN INTAR -- USED BY CHNINT, JOBINT, AND FNYINT
CHNI4C: MOVE F,UNREAR ;STACK UP INTERRUPT IN THE
CAIL F,LUNREAR ; NOINTERRUPT QUEUE
JRST TMDAMI ;OOPS! TOO MANY DAMN INTERRUPTS!
MOVE F,[400000+LUNREAR-1,,UNREAR+LUNREAR-2]
CHNI4H: POP F,1(F)
TLNE F,377777
JRST CHNI4H
MOVEM D,UNREAR+1
AOS UNREAR
HRRZ F,INTPDL
JRST 2(R)
;JOBINT
; COMMENT FOR @ CHANGE
IFN JOBQIO,[
;;; INTERRUPT FROM INFERIOR PROCEDURE(S)
JOBINT: MOVE F,INTPDL
MOVE D,IPSWD2(F)
MOVE R,FXP
SKIPE GCFXP ;IF IN GC, FXP MAY BE
MOVE FXP,GCFXP ; SCREWED UP
PUSH FXP,R
MOVN R,D
AND R,D ;R GETS LOWEST SET BIT
ANDCM D,R ;D GETS ALL OTHER BITS
SKIPE D
.SUSET [.SIIFPIR,,D] ;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED)
MOVE D,R
JFFO D,.+1
MOVNS R ;-22 < R < -11
SKIPN D,JOBTB+21(R)
.VALUE ;NO JOB ARRAY???
HRRZ R,TTSAR(D)
SKIPN J.INTF(R)
JRST INTXIT ;NO INTERRUPT FUNCTION - IGNORE INTERRUPT
MOVSI D,(D)
TRO D,200000+<2*J.INTF+1>
SKIPGE UNREAL
JSP R,CHNI4C ;GORP! (NOINTERRUPT T)
PUSHJ FXP,$IWAIT
JRST XUINT
JRST INTXIT
] ;END OF IFN JOBINT
;TTYICH TTYIC1
;;; TTSAR OF TTY INPUT FILE ARRAY IN TT.
;;; INPUT INTERRUPT CHARACTER IN R.
;;; RETURN ADDRESS IN D.
;;; RETURNS INTERRUPT FUNCTION IN R.
TTYICH:
IT$ TRZ R,%TX<TOP+SFL+SFT+MTA> ;FOLD 12.-BIT CHAR
SA$ ANDI R,777
SA% TRZN R,%TX<CTL> ; DOWN TO 7 IF NECESSARY
SA% JRST TTYIC1
SA% CAIE R,177
SA% TRZ R,140
TTYIC1: ROT R,-1 ;CLEVER ARRAY ACCESS
ADDI TT,FB.BUF(R) ;INTERRUPT FNS ARE IN "BUFFER"
HLR R,(TT)
SKIPGE R
HRRZ R,(TT) ;SIGN BIT OF R GETS CLEARED
JRST (D)
;CN.W CN.Z CN.Z0 ALTP CN.Z ALTP CN.Z CKI2I CTRLG CN.X CN.G CN.G1
SUBTTL VARIOUS SYSTEM TTY INPUT CHAR INTERRUPT HANDLERS.
CN.W: HRRZM D,TTYOFF ;IMMEDIATE TTYOFF (↑W)
PUSH FXP,T
PUSH FXP,TT
HRRZ TT,V%TYO
MOVE TT,TTSAR(TT)
PUSHJ FXP,CLRO3 ;ALSO DO (CLEAR-OUTPUT T)
POP FXP,TT
POP FXP,T
JRST CHNI2
IFN D20,[
CN.Z: MOVEI T,CN.Z0 ;RETURN TO SUPERIOR (MAY BE IDDT)
MOVE TT,INTPDL
EXCH T,IPSPC(TT)
MOVEM T,CN.ZX
JRST CHNI2 ;ALPT$G PROCEEDS
CN.Z0: HALTF
ALTP: JRST 2,@CN.ZX
] ;END IFN D20
IFN D10,[
CN.Z: SKIPE R,.JBDDT ;ANY DDT IN CORE?
JRST (R)
EXIT 1, ;RETURN TO MONITOR IF NO DDT, CONT CONTINUES
ALTP: JRST CHNI2 ;PROCEED ON ALTP$G
] ;END IFN D10
IFN ITS,[
CN.Z: PUSH FXP,TT ;WE NEED ONE AC TO HOLD CHANNEL NUMBER
HRRZ TT,-2(FXP)
.CALL CKI2I
.VALUE
POP FXP,TT
.VALUE [ASCIZ \:≠DDT≠
\]
JRST CHNI2
CKI2I: SETZ
SIXBIT \RESET\
400000,,TT
] ;END IFN ITS
CTRLG: HRROI D,-3 ;↑G - SUBR 0
PIPAUSE ;DISABLE THE INTERRUPT SYSTEM FOR NOW
SETZM UNREAR ;CLEAR OUT ALL STACKED INTERRUPTS
SETZM INTAR
HRREM D,INTFLG
SKIPE NOQUIT ;HOW CAN NOQUIT BE NON-ZERO?
IT$ .LOSE ; MAYBE THE USER SCREWED UP
IFN D10+D20, HALT
JRST CKI0 ;PROCESS THE FORCED QUIT
CN.X: SKIPA D,[-6] ;ERRSETABLE (↑X) QUIT
CN.G: HRROI D,-7 ;IMMEDIATE (↑G) QUIT
SKIPE UNREAL
JRST CN.G1
SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP
HRREM D,INTFLG
PUSHJ FXP,$IWAIT
SKIPA D,[CKI0]
JRST CHNI2 ;CAN'T PROCESS QUIT NOW
MOVEM D,IPSPC(F) ;IF CAN QUIT NOW, ARRANGE FOR SERVER
JRST CHNI2 ; TO RETURN TO INTERRUPT CHECKER
CN.G1: SETZM UNREAR ;KILL STACKED UNREAL INTERRUPTS
EXCH D,UNRC.G ;ELSE STACK UP AN UNREAL
TRNE D,1 ; ↑G OR ↑X INTERRUPT
MOVEM D,UNRC.G ;DON'T LET A ↑X DISPLACE A ↑G
JRST CHNI2
;REALCLOCK RUNCLOCK RCLOK1 FNYINT FNYIN0 RCLOK2
IFN ITS,[
;;; REAL TIME ALARMCLOCK
REALCLOCK:
MOVSI R,400000 ;SHUT CLOCK BACK OFF
.REALT R,
MOVEI R,Q$TIME
JRST RCLOK1
;;; RUNTIME ALARMCLOCK
RUNCLOCK:
MOVEI R,Q$RUNTIME
RCLOK1: MOVE F,INTPDL
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
SKIPN VALARMCLOCK ;IGNORE IF THERE IS NO
JRST INTXIT ; ALARMCLOCK FUNCTION
MOVSI D,(R) ;TYPE 0, SUBTYPE 0 IS ALARMCLOCK
SKIPL UNREAL ;SKIP IF (NOINTERRUPT T)
JRST RCLOK2
MOVEM D,UNRRUN-Q$RUNTIME(R) ;STACK UP INTERRUPT
JRST INTXIT
IFN USELESS,[
FNYINT: MOVE F,INTPDL ;COMMON HANDLER FOR FUNNY INTERRUPTS
MOVE D,FXP
SKIPE GCFXP
MOVE FXP,GCFXP
PUSH FXP,D
MOVE R,(R)
SKIPN (R)
JRST INTXIT ;EXIT IF NO USER HANDLER
HLRZ D,R
CAIE D,UIFTTR ;SPECIAL HACK FOR TTY-RETURN
JRST FNYIN0
HRRZ R,IPSPC(F) ;GET PC OF INTERRUPT
CAIE R,TYICAL ;INTERRUPTED FROM CANONICAL INPUT WAIT?
CAIN R,TYICA1
HRLI D,Q$IN ;YES, ARG TO INT FUN IS 'IN
CAIN R,TYIXCT ;ANOTHER CANNONICAL PLACE
HRLI D,Q$IN
FNYIN0: SKIPGE UNREAL
JSP R,CHNI4C ;MUST STACK UP IF UNREAL
] ;END OF IFN USELESS
RCLOK2: PUSHJ FXP,$IWAIT ;WILL STACK AND SKIP IF GC
JRST XUINT ;GIVE USER CLOCK INTERRUPT
JRST INTXIT
;CLIINT TTRINT SYSINT MARINT
IFN USELESS,[
;;; CLI INTERRUPT HANDLER
CLIINT: JSP R,FNYINT
UIFCLI,,VCLI
;;; RETURN OF TTY TO THE JOB
TTRINT: JSP R,FNYINT
UIFTTR,,VTTR
;;; SYSTEM GOING DOWN OR BEING DEBUGGED
SYSINT: JSP R,FNYINT
UIFSYS,,VSYSD
;;; MAR BREAK
MARINT: MOVEI R,%PIMAR
ANDCAM R,IMASK
.SUSET [.SMASK,,IMASK]
.SUSET [.SMARA,,R70]
MOVEI R,1+.LZ %PIMAR
SKIPN VMAR
JRST INTLS1 ;IN CASE (STATUS MAR) GETS LOUSED UP
JSP R,FNYINT
UIFMAR,,VMAR
] ;END OF IFN USELESS
] ;END IFN ITS
;YESIN1 UISTK1 UISTK2 TMDAMI TMDAM2 QMARK
;;; STACK UP A USER INTERRUPT WHICH MUST BE DELAYED.
;;; ARGUMENT IS IN D AS FOR UINT; IT IS SAVED IN THE INTAR QUEUE.
;;; ASSUMES FREE USE OF ACCUMULATOR R.
;;; PI INTERRUPTS MUST BE DISABLED!!!!
.SEE PIOF
YESIN1: POP P,UISTAK ;THIS IS A HORRIBLE CROCK
;UISTAK: 0
UISTK1: MOVE R,INTFLG ;IF WE ARE ABOUT TO QUIT ANYWAY,
AOJL R,@UISTAK ; THEN FORGET THE WHOLE THING
AOS R,INTAR
CAILE R,LINTAR
JRST TMDAMI ;TOO MANY DAMN INTERRUPTS
MOVE R,[400000+LINTAR-1,,INTAR+LINTAR-2]
UISTK2: POP R,1(R)
TLNE R,377777
JRST UISTK2
MOVSM D,INTAR+1
SETOM INTFLG
JRST @UISTAK
TMDAMI: SKIPN GCFXP ;TOO MANY DAMN INTERRUPTS
JRST TMDAM2
IRP X,,[P,FLP,FXP,SP]
MOVE X,GC!X
TERMIN
TMDAM2:
; LERR [SIXBIT \TOO MANY DEFERRED INTERRUPTS!\]
IFN ITS,[
.VALUE [ASCIZ \:≠TOO MANY DEFERRED INTERRUPTS≠↔CONTIN⊗
\]
.LOSE
] ;END OF IFN ITS
10$ OUTSTR [ASCIZ \TOO MANY DEFERRED INTERRUPTS\]
10$ EXIT 1,
10$ JRST .-1
IFN D20,[
HRROI 1,[ASCIZ \
?Too many deffered interrupts
\]
HALTF
] ;END IFN D20
;QMARK -- THIS IS HERE SO BAKTRACE WILL FIND IT AS LAST SUBR (ARGG!!)
QMARK: MOVEI A,QM
POPJ P,
;PURPGI PPGI3 PPGI5 PPGI6
;;; PURE PAGE TRAP HANDLER
;;; COMES HERE WITH LOSING PC IN D.
.SEE MEMERR
PURPGI:
IFN D10*<1-SAIL>,[
SKIPE KA10P
SOSA D,IPSPC(F) ;MAKE PC POINT TO OFFENDING INSTRUCTION
SKIPA
ANDI D,-1
] ;END OF IFN D10*<1-SAIL>
CAIN D,STQPUR
JRST PPGI5
IFN PAGING,[
MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS
] ;END IFN PAGING
JUMPGE D,PURERR
PPGI3: HRRM D,IPSPC(F)
JRST INTXIT
PPGI5: MOVEM A,STQLUZ ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK
MOVE D,[TIRPATE,,NIL]
MOVEM D,(SP)
SKIPE GCFXP
.VALUE
AOS IPSPC(F) ;DON'T RETRY THE LOSING INSTRUCTION!
PUSHJ FXP,$IWAIT ;LET SPDL GET CAUGHT UP
SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T
JRST PURERR ;INTWAIT MAY SKIP
PPGI6: HRRZI D,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL
JRST PPGI3
;UIMPAR UIMILO UIMWRO UIMMPV UIFCLI UIFMAR UIFTTR UIFSYS NUINT1 NUINT2
SUBTTL USER INTERRUPT ROUTINES
;;; USER INTERRUPT TYPES FOR NEWIO
;;;
;;; FORM OF ARGUMENT TO UINT (ALSO STORED IN THIS FORM
;;; IN INTAR, ONLY WITH HALVES SWAPPED; WHY, I DON'T KNOW):
;;;
;;; 4.9-3.1 ARGUMENT FOR INTERRUPT FUNCTION
;;; 2.9 IF 1, SPECIFIES A TTY INPUT CHARACTER INTERRUPT.
;;; ARGUMENT IS TTY INPUT FILE ARRAY.
;;; 2.8-2.4 MUST BE ZERO.
;;; 2.3-1.1 CHARACTER WHICH CAUSED INTERRUPT, AS
;;; READ BY .ITYIC. THIS MAY BE A 12.-BIT
;;; CHARACTER, AND SO MAY HAVE TO BE FOLDED
;;; BEFORE SELECTING THE INTERRUPT FUNCTION.
;;; THIS IS PASSED AS THE SECOND ARGUMENT.
;;; 2.8 IF 1, SPECIFIES AN INTERRUPT RELATED TO A FILE
;;; ARRAY OR SIMILAR OBJECT, E.G. THE **MORE**
;;; INTERRUPT FOR TTY OUTPUT.
;;; ARGUMENT IS THE FILE ARRAY.
;;; 2.7-1.1 IS THE INDEX OF THE INTERRUPT FUNCTION
;;; WITHIN THE ARRAY, WHERE THE LOW BIT SPECIFIES
;;; LEFT OR RIGHT HALF AS USUAL.
;;; 2.7 IF 1, SPECIFIES A MACHINE ERROR.
;;; THE ARGUMENT IS THE LOCATION OF THE LOSS.
;;; BITS 1.9-1.1 SPECIFY THE NATURE OF THE ERROR.
UIMPAR==:0 ;ODDP ;PARITY ERROR
UIMILO==:1 ;EVAL ;ILLEGAL OPERATION
UIMWRO==:2 ;DEPOSIT ;WRITE INTO READ-ONLY MEMORY
UIMMPV==:3 ;EXAMINE ;MEMORY PROTECT VIOLATION
;;; IF 2.9-2.7 ARE ZERO, THEN:
;;; 2.2-2.1 TYPE OF INTERRUPT
;;; 1.9-1.1 SPECIFIC INTERRUPT
;;; CURRENT TYPES AND SPECIFIC INTERRUPTS ARE:
;;; 0 RANDOM ASYNCHRONOUS (DELAYED BY (NOINTERRUPT T))
;;; 0 ALARMCLOCK
UIFCLI==:1 ;CLI-MESSAGE ;USELESS
UIFMAR==:2 ;MAR-BREAK ;USELESS
UIFTTR==:3 ;TTY-RETURN ;USELESS
UIFSYS==:4 ;SYS-DEATH ;USELESS
IFE USELESS, NUINT0==:1 .SEE GCP6Q6
IFN USELESS, NUINT0==:5 .SEE GCP6Q6
;;; 1 RANDOM SYNCHRONOUS
;;; 0 AUTOLOAD
;;; 1 ERRSET FN
;;; 2 *RSET-TRAP
;;; 3 GC-DAEMON
;;; 4 GC-OVERFLOW
;;; 5 PDL-OVERFLOW
NUINT1==:6 .SEE GCP6Q6
;;; 2 ERINT (SYNCHRONOUS)
;;; 0 UNDF-FNCTN
;;; 1 UNBND-VRBL
;;; 2 WRNG-TYPE-ARG
;;; 3 UNSEEN-GO-TAG
;;; 4 WRNG-NO-ARGS
;;; 5 GC-LOSSAGE
;;; 6 FAIL-ACT
;;; 7 IO-LOSSAGE
NUINT2==:10 .SEE GCP6Q6
;UINT UINTEX UINTX1 UINT2 UINT3 HHCTB UINTPU
;;; WE NORMALLY DON'T PUSHJ HERE AT ALL FROM PI LEVEL!
;; (THINK ABOUT HOW TO SIMPLIFY THE CODE HERE.)
UINT: PUSHJ P,UINTPU
SKIPN NOQUIT
SKIPE INHIBIT
JRST UINT2
SKIPGE INTFLG
JRST UINT3
PUSHJ P,UINT0
.SEE UINTPU ;PEOPLE COME HERE TO UNDO UINTPU
;NOTE: THE PUSH'S OF UINTPU MUST SYNC WITH THE POP'S HERE
UINTEX:
IFN <D10+D20>,[
POP FXP,OIMASK
POP FXP,IMASK
] ;END IFN <D10+D20>
SKIPL (FXP)
JRST UINTX1
PIONAGAIN
IT$ .SUSET [.SDF1,,R70]
IT$ .SUSET [.SDF2,,R70]
UINTX1: SUB FXP,R70+1 ;GET RID OF REENABLE INTERRUPTS FLAG
POP FXP,R .SEE UINTPU
JRST CHECKI ;PDL-OVERFLOW MAY HAVE BEEN STACKED
.SEE PDLOV
UINT2: JSR UISTAK ;DELAY A USER INTERRUPT, SINCE INHIBIT SWITCH IS ON
JRST UINTEX
UINT3: HRRZ D,INTFLG ;CHECK INTERRUPT FLAG TO SEE THAT IS SAYS "QUIT"
CAIE D,-1 ;AND NOT SOME INCONGRUOUS USER PI
JRST CKI2
HHCTB: .VALUE
; LERR EMS11 ;HOW THE HELL CAN THIS BE?
UINTPU: ;PUSH PI STATE, THEN DISABLE
PUSH FXP,R ;SAVE R FOR UISTAK, ETC.
PUSH FXP,T
IFE ITS,[
PUSH FXP,IMASK ;SAVE APRENB MASKS
PUSH FXP,OIMASK
MOVN T,INTALL ;GET PI STATE FROM INTERNAL WORD
EXCH T,-2(FXP)
SKIPGE -2(FXP)
PIPAUSE
] ;END IFE ITS
IFN ITS,[
.SUSET [.RPICLR,,T]
EXCH T,(FXP)
SKIPGE (FXP)
PIPAUSE
] ;END OF IFN ITS
POPJ P,
;YESINT UINT0 UIXPUSH UISWS UISAVT UIFRM UISAVA
;;; SAVE THE WORLD FOR A USER INTERRUPT, INVOKE IT, AND RESTORE.
;;;
;;; SAVED QUANTITIES INCLUDE ALL ACCUMULATORS, THE PDL POINTERS
;;; (FOR FRETURN), AND THE SUPER-WRITABLE STUFF (TEMPORARIES IN
;;; LOW CORE USED BY INTERRUPTABLE FUNCTIONS).
;;; MANY GLOBAL SWITCHES ARE BOUND AND RESET.
;;; FOR ASYNCHRONOUS USER INTERRUPTS, THE (NOINTERRUPT T) STATE
;;; MAY BE ENTERED; THE PREVIOUS NOINTERRUPT STATE IS SAVED.
;;; MUST NOT COME HERE WITHOUT FIRST USING THE $IWAIT
;;; ROUTINE TO DECIDE WHETHER OR NOT WE ARE IN GC.
;;; ALSO MUST CHECK THE NOINTERRUPT SWITCH BEFORE COMING HERE
;;; IF THAT IS RELEVANT TO THE PARTICULAR USER INTERRUPT.
;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE.
;;; THE WORD DESCRIBING THE USER INTERRUPT MUST BE IN D.
YESINT: SKIPN NOQUIT
SKIPE INHIBIT
JRST YESIN1
UINT0:
IT$ .SUSET [.SDF1,,TTYDF1] ;MUST ALLOW PDL OVERFLOW AND MEMORY
IT$ .SUSET [.SDF2,,TTYDF2] ; ERRORS TO GO THROUGH, BUT NO OTHERS
IT$ PION
IFN D10+D20,[
SETZM INTALL ;UNDO THE 'DALINT'
PUSHJ P,DISINT ;DISABLE APPROPRIATE INTERRUPTS
] ;END IFN D10+D20
HRRZS (P) ;WILL HRROS IF ASYNCHRONOUS
PUSHJ P,SAVX5 ;SAVE NUMERIC ACS
PUSH FXP,UNREAL
BG$ PUSH FXP,BNV1
MOVSI R,-LSWS
PUSH FXP,SWS(R)
AOBJN R,.-1
JSP T,SPECBIND ;MUST SPECBIND LISAR
LISAR
SETZM PA4 ;PA4 MUST BE IN THE "SWS" AREA
IFN USELESS, SETZM TYOSW
SETZM INHIBIT
SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS
SETZM BFPRDP ; TO THROW OUT OF USER INTERRUPTS
SETOM ERRSW
MOVE T,[-LINTPDL,,INTPDL] ;MUSTN'T CALL UINT0 FROM
CAME T,INTPDL ; WITHIN A PI SERVER
.LOSE
REPEAT 3, PUSH FXP,R70 ;RANDOM SLOTS FOR NUMERIC ARGS;
; ; ALSO 4.9 OF TOP ONE => RETURN VALUE MATTERS
UIXPUSH==:5+1+BIGNUM+LSWS+3 ;AMOUNT OF STUFF PUSHED ON FXP
UISWS==:-<LSWS+3>+1 ;WHERE SWS STARTS WHEN SAVED ON FXP
UISAVT==:UISWS-6-BIGNUM ;WHERE ACCUMULATOR T GETS SAVED
PUSH P,[$UIFRAME] ;FRAME MARKER AND PDLS SAVED
PUSH P,FXP ; SO THAT THROW AND FRETURN WIN
HRLM FLP,(P) .SEE UIBRK
PUSHJ FXP,SAV5 ;SAVE ARGUMENT ACS AND 40 ON
PUSH P,40 ; REGPDL FOR GC PROTECTION
PUSH P,PA3
UIFRM==-3-NACS ;LOCATION OF FRAME ON REGPDL
UISAVA==UIFRM+2 ;LOCATION OF AC A ON REGPDL
MOVEI A,UIFRM(P)
MOVEM A,UIRTN
MOVSI AR2A,(CALLF 1,)
HLRZ A,D ;GET FIRST ARG FOR INTERRUPT FN
TRZN D,400000 ;DECODE INTERRUPT TYPE
JRST UINT30
HRRZM D,(FXP) ;TTY INPUT INTERRUPT CHAR
MOVEI R,(D)
MOVE TT,TTSAR(A)
JSP D,TTYICH ;FETCH INTERRUPT FN
MOVSI AR2A,(CALLF 2,)
HRRI AR2A,(R)
MOVEI B,(FXP) ;SECOND ARG IS CHARACTER
JRST UINT31
;UINT30 UINT31 UINT32 UINT33 UINT40 UINT0X UINT0N UINT0Z UINT88 EUINT0 UINT45 UINT46 UINT49 UINT90 UINT91
UINT30: TRZN D,200000
JRST UINT32
MOVEI TT,(D) ;RANDOM FILE INTERRRUPT
ROT TT,-1
HRR AR2A,@TTSAR(A) ;FETCH INTERRUPT FUNCTION
SKIPL TT
HLR AR2A,@TTSAR(A)
UINT31: HRROS UIFRM-1(P) ;ASYNCHRONOUS INTERRUPT
JRST UINT40
UINT32: TRZN D,100000
JRST UINT33
HRRZM A,-1(FXP)
MOVEI A,QODDP(D) ;MACHINE ERROR
MOVEI B,(FXP)
MOVEI C,-1(FXP)
MOVEI AR1,-2(FXP)
MOVSI AR2A,(CALLF 4,)
HRR AR2A,VMERR
JRST UINT40
UINT33: LDB TT,[110200,,D] ;BITS 2.2-2.1 ARE CLASS
ANDI D,777 ;1.9-1.1 ARE SUBTYPE
XCT UINT90(TT) ;FETCH INTERRUPT FUNCTION
XCT UINT91(TT) ;SPECIAL HACKS
UINT40: SKIPGE UIFRM-1(P)
SETOM UNREAL
PIONAGAIN ;***** RE-ENABLE INTERRUPTS *****
IT$ .SUSET [.SDF1,,R70]
IT$ .SUSET [.SDF2,,R70]
TRNN AR2A,-1 ;ONLY PROCESS INTERRUPT IF INT FUNCTION NON-NIL
TDZA A,A ;FORCE A RETURNED VALUE OF NIL IF IT MATTERS
XCT AR2A ;APPLY INTERRUPT FUNCTION
HRRZ T,UIFRM+1(P)
CAIE T,(FXP)
PUSHJ P,UINT45
HLRZ T,UIFRM+1(P)
CAIE T,(FLP)
PUSHJ P,UINT46
PIPAUSE
SKIPGE (FXP) ;IF RETURN VALUE MATTERS
MOVEM A,UISAVA(P) ; SAVE IT FOR RETURN
PUSHJ P,UNBIND ;RESTORE LISAR, ETC.
UINT0X: HRLI R,UISWS(FXP)
HRRI R,SWS
BLT R,SWS+LSWS-1 ;RESTORE SUPER-WRITABLE STUFF
SUB FXP,[-UISWS+1,,-UISWS+1]
BG$ POP FXP,BNV1
POP P,PA3
POP P,40
PUSHJ FXP,RST5M1
POP P,-2(P) ;KNOCK OFF PDLS AND UIFRAME, SAVING
SUB P,R70+1 ; SAVED CONTENTS OF A FOR POPAJ BELOW
POP FXP,D ;OLD STATE OF UNREAL
SKIPL -1(P) ;IF INTERRUPT WASN'T ASYNCHRONOUS,
JRST UINT88 ; MUSTN'T ATTEMPT TO RESTORE UNREAL
EXCH D,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON
JUMPE D,UINT88 ; JUST NOW? IF NOT, RETURN.
SKIPE A,UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT?
JRST UINT0Z ;NO, IT'S STILL ON - RETURN.
UINT0N: HRRZ T,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME?
CAIGE T,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY
CAIGE T,NOINTERRUPT ; RECURSIVE CALLS
PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU
JRST UINT88
UINT0Z: SKIPLE UNREAL
JUMPLE D,UINT0N
UINT88: PUSHJ P,RSTX5
PIONAGAIN ;RE-ENABLE INTERRUPTS
JRST POPAJ
EUINT0:: .SEE PDLOV ;END OF UINT0
UINT45: SKIPA B,[QFIXNUM]
UINT46: MOVEI B,QFLONUM
EXCH A,B
PUSHJ P,UINT49
EXCH A,B
POPJ P,
UINT49: FAC [PDL OUT OF PHASE IN USER INTERRUPT (SYSTEM ERROR)!]
UINT90: HRR AR2A,VALARMCLOCK(D) ;ALARMCLOCK SERIES
HRR AR2A,VAUTFN(D) ;RANDOM SYNCHRONOUS
HRR AR2A,VUDF(D) ;ERINT SERIES
.VALUE ;??
UINT91: HRROS UIFRM-1(P) ;ALARMCLOCK (ASYNCHRONOUS)
JFCL ;RANDOM SYNCHRONOUS
SETOM (FXP) ;ERINT (VALUE MATTERS)
.VALUE ;??
;CKI0 CKI2 CKI2A CKI2F CKI2F1 CKI3 CKI3B RQITR CKI4A CKI1 CKI1A
CKI0: PUSH FXP,D
HRRZ D,INTFLG
CAIN D,-1
JRST CKI1 ;DELAYED USER INTERRUPT
PIPAUSE
CKI2: SETZM UNREAR
CKI2A: SETZM UNRC.G ;CHECKU JOINS IN AT THIS POINT
SETZM INTFLG ; RESET TTY NO RESET
TRNE D,4 ;↑X -6 -2
JRST CKI3 ;↑G -7 -3
IFN ITS+D20,[
PUSH FXP,D
MOVEI F,LCHNTB-1 ;RESET ALL TTY FILES
CKI2F: SKIPN AR1,CHNTB(F)
JRST CKI2F1
MOVE TT,TTSAR(AR1)
TLNN TT,TTS.CL ;DON'T RESET THE FILE IF IT IS CLOSED
TLNN TT,TTS.TY
JRST CKI2F1
MOVEI T,CLRI3
TLNE TT,TTS.IO
MOVEI T,CLRO3
PUSHJ FXP,(T)
CKI2F1: SOJG F,CKI2F
POP FXP,D
] ;END OF IFN ITS+D20
10$ CLRBFO
10$ CLRBFI
CKI3:
CKI3B: TRNN D,2
SKIPE PSYMF
RQITR: LERR [SIXBIT \QUIT!\] ;SO ERROR OUT FOR ↑X
IFN USELESS*ITS,[
MOVE T,IMASK
TRNN T,%PIMAR
JRST CKI4A
.SUSET [.RMARA,,SAVMAR]
.SUSET [.SMARA,,R70] ;AVOID TRIPPING THE MAR DURING THE ERRPOP
CKI4A:
] ;END OF IFN USELESS*ITS
PIONAGAIN
PUSHJ FXP,ERRPOP
PIPAUSE
IFN USELESS*ITS,[
TRNE T,%PIMAR ;ERRPOP PRESERVES T
.SUSET [.SMARA,,SAVMAR]
] ;END OF IFN USELESS*ITS
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JSP A,ERINI0
MOVE P,C2 ;DRASTIC ACTION FOR ↑G
SETZM TTYOFF
STRT 17,@RQITR
JRST LSPRT1 ;WILL PION WITHIN ERINIT
CKI1: SKIPE INHIBIT ;RETURN TO SERVICE THE DELAYED INTERRUPT
JRST POPXDJ ;BUT NO SERVICE WHEN INHIBIT = -1
PUSHJ P,UINTPU
SETZM INTFLG
PUSH P,A
PUSH P,A
HLLOS INHIBIT
SKIPG A,INTAR
LERR EMS13 ;LOST USER INTERRUPT
CKI1A: MOVS D,INTAR(A) ;FOR GC PROTECTION
MOVSM D,(P)
SOSG INTAR ;CYCLE THROUGH THE DELAYED INTERRUPTS
SETZM INTFLG ;TO PREVENT TIMING SCREWS, CLEAR INTFLG IF
; NO MORE INTERRUPTS PENDING
PUSHJ P,UINT0
SKIPLE A,INTAR
JRST CKI1A
SUB P,R70+1
POP P,A
SETZM INHIBIT
PUSHJ P,UINTEX
JRST POPXDJ
;UUOH0 UUOH2 UUOH2A UUOACL UUOAJC
SUBTTL UUOH HANDLER (INCLUDING STRT)
;UUOH: 0 ;UUO HANDLER
UUOH0: MOVEM T,UUTSV
LDB T,[331100,,40]
CAIL T,CALL←-33
JRST UUOH0B ;PROBABLY A LISP "CALL" UUO
UUOH2: CAILE T,UUOMAX
SETZ T,
JRST @UUOH2A(T)
UUOH2A: ERRBAD ;0 IS ILGL, ILGL, ILGL
ERROR1 ;LERR ;UNCORRECTABLE LISP ERROR
UUOACL ;ACALL ;KLUDGE FOR NCALLING ARRAYS
UUOAJC ;AJCALL ;JRST VERSION OF ACALL
ERROR1 ;LER3 ;LERR, BUT ALSO PRINT ACCUMULATOR A
ERROR5 ;ERINT ;CORRECTABLE ERROR WITH SIXBIT MSG
POF1 ;PP Z$X ;PRINT OUT Z FROM DDT
STRTOUT ;STRT ;SIXBIT STRING TYPE OUT
ERROR5 ;SERINT ;CORRECTABLE ERROR WITH S-EXP MSG
TOF1 ;TP Z$X ;TYPEP PRINTOUT OF Z FROM DDT
ERRIOJ ;IOJRST ;HAIRY FROB TO GET I/O ERROR MSGS
IFN .-UUOH2A-1-UUOMAX, WARN [UUOH2A OUT OF PHASE]
UUOACL: PUSH P,UUOH
BAKPRO
UUOAJC: MOVE T,@40 .SEE ASAR
TLNE T,AS<FX+FL>
AOJA T,.+2 ;FOR NUMBER ARRAYS, ENTER AT HEADER+1
PUSH P,[UUONVL] ;FOR OTHER ARRAYS, USE NUMVAL CHECK ROUTINE
XCTPRO
EXCH T,UUTSV
SPECPRO INTACT
JRST @UUTSV
NOPRO
;UUOH0B UUOH0A UUOH1 UUOH0C UUOH1A UUOH3B
;;; DISPATCH ON "CALL" TYPE UUO, TRAPPING TO INTERPRETER IF NECESSARY
UUOH0B: CAILE T,NJCALF←-33
JRST UUOH2
MOVEM TT,UUTTSV
MOVEM R,UURSV
LDB TT,[270400,,40]
CAIG TT,15 ;LISP "CALL" TYPE UUOS
TDZA R,R
MOVEI R,-15(TT)
HRRZ T,40
UUOH0A: MOVEM T,UUOFN
TLZ T,-1
MOVEI TT,(T)
LSH TT,-SEGLOG
SKIPGE TT,ST(TT)
JRST @UUNAF(R)
TLNN TT,SY
JRST UUOH0C
TLZ R,700000 ;400000 => AUTOLOAD, 200000 => MACRO,
; 100000 => ALREADY DID AUTOLOAD
UUOH1: HRRZ T,(T)
JUMPE T,UUOH1A
HLRZ TT,(T)
HRRZ T,(T)
CAIL TT,QARRAY
CAILE TT,QAUTOLOAD
JRST UUOH1
2DIF JRST @(TT),UUOTRT,QARRAY
UUOH0C: TLNN TT,SA
JRST UUOH3A
HRRZ TT,ASAR(T) ;HANDLE CASE OF A SAR EFFICIENTLY
CAIN TT,ADEAD
JRST UUOH3A
MOVSI T,(T)
HRRI T,T
JRST @UUAT(R)
UUOH1A: JUMPL R,UUALT1
TLNE R,200000
JRST UUOMER
PUSH P,A
PUSH P,B
SKIPGE A,UUOFN
JRST UUOUER
HLRZ T,(A) ;OPENCODED SYMEVAL
HRRO T,@(T)
UUOH3B: POP P,B
POP P,A
SKIPN EVPUNT ;SHOULD WE ALLOW FUNCTIONAL VARIABLES?
CAIN T,QUNBOUND ;YES, IS IT BOUND?
JRST UUOH3A ;NO TO EITHER QUESTION, SO ERROR
JRST UUOH0A
;UUOTRT UUAT UUST UUFST UULT UUET UUFET UUNAF UUALT UUMCT UUALT1
;;UUO TRANSFER TABLE, ONCE FUNCTION TYPE IS KNOWN
UUOTRT:
IRPS LL,X,[A+S+FS+L+E+FE+MC-AL-]
IFSE X,+, @UU!LL!T(R)
IFSE X,-, UU!LL!T
TERMIN
;;; MOBY DISPATCH TABLE FOR DECODING UUO CALL TYPES!
;;; R=0 => COMPILED ROUTINE CALLING A SUBR TYPE
;;; R=1 => COMPILED ROUTINE CALLING A LSUBR TYPE
;;; R=2 => COMPILED ROUTINE CALLING A FSUBR TYPE
UUAT: UUOARR ;CALLING SUBR - IT'S AN ARRAY **WIN**
UUOS1A ;CALLING LSUBR - IT'S AN ARRAY
UUOS2A ;CALLING FSUBR - IT'S AN ARRAY
UUST: UUOS0 ;CALLING SUBR - IT'S A SUBR **WIN**
UUOS1 ;CALLING LSUBR - IT'S A SUBR
UUOS2 ;CALLING FSUBR - IT'S A SUBR
UUFST: UUOS10 ;CALLING SUBR - IT'S AN FSUBR
UUOS11 ;CALLING LSUBR - IT'S AN FSUBR
UUOSBR ;CALLING FSUBR - IT'S AN FSUBR **WIN**
UULT: UUOS7 ;CALLING SUBR - IT'S AN LSUBR
UUOLSB ;CALLING LSUBR - IT'S AN LSUBR **WIN**
UUOS9 ;CALLING FSUBR - IT'S AN LSUBR
UUET: UUOEXP ;CALLING SUBR - IT'S AN EXPR
UUOS5 ;CALLING LSUBR - IT'S AN EXPR
UUOS6 ;CALLING FSUBR - IT'S AN EXPR
UUFET: UUOS3 ;CALLING SUBR - IT'S A FEXPR
UUOS4 ;CALLING LSUBR - IT'S A FEXPR
UUOEX2 ;CALLING FSUBR - IT'S A FEXPR
UUNAF: UUOS ;CALLING SUBR - IT'S A NONATOMICFUN
UUL2N ;CALLING LSUBR - IT'S A NONATOMICFUN
UUF2N ;CALLING FSUBR - IT'S A NONATOMICFUN
UUALT: HRRZM T,UUALT9 ;FOUND AN AUTOLOAD PROPERTY
TLOA R,400000
UUMCT: TLO R,200000 ;MACROS ARE IGNORED, SORT OF
JRST UUOH1
UUALT1: TLOE R,100000 ;CALLING ANYTHING - IT'S AN AUTOLOAD
JRST UUOH3C ;LOSE IF JUST DID AN AUTOLOAD ALREADY
PUSH P,A
HLRZ A,@UUALT9 ;OTHERWISE AUTOLOAD THE FUNCTION
MOVE T,UUOFN
PUSHJ P,AUTOLOAD ;BETTER SAVE R, BY GEORGE!
POP P,A
MOVE T,UUOFN
JRST UUOH1 ;NOW TRY IT AGAIN
;UUOBNC UUOBAK UUBKG1 UUOBK7 UUOBK0 UUOBK1 UUOBK8 UUOBK5 UUOBK6
;;; MAY CALL UUOBNC AND UUOBAK ONLY WHEN *RSET IS KNOWN
;;; TO BE NON-NIL - AVOIDS CERTAIN TIMING ERRORS.
UUOBNC: POP P,UUOBKG ;UUOBKG WITH NO CPOPJ
HRROS UUOBKG ;FOR UUO GUYS THAT CALL IAPPLY,
JRST UUOBK0 ; WHICH ITSELF SETS UP A CPOPJ
UUOBAK: POP P,UUOBKG ;WATCH THIS CROCK!
JRST UUOBK7
;;;UUOBKG: 0
UUBKG1: SKIPN V.RSET ;CHECK TO SEE WHETHER IN *RSET MODE
JRST @UUOBKG ;SAVES ALL ACS; T HAS -<# OF ARGS>
UUOBK7: HRRZS UUOBKG
UUOBK0: SKIPE NIL
PUSHJ P,NILBAD
PUSH FXP,TT ;PDLS MUST BE AS FRETURN WOULD WANT
PUSH FXP,R ; TO RESTORE THEM TO
JUMPGE T,UUOBK1 ;IF T>0, THEN ASSUME 0, AND THE
JSP TT,ARGP0 ; ARGS WILL BE FILLED IN LATER
MOVNI TT,(T)
SKIPGE A
SETZ TT,
HRLM TT,(P)
JRST UUOBK8
UUOBK1: PUSH P,R70
UUOBK8: MOVEI TT,-2(FXP)
HRLI TT,(FLP)
PUSH P,TT
HRRZ TT,40
HRLI TT,(SP)
PUSH P,TT
JUMPLE T,UUOBK5
PUSH P,R70
JRST UUOBK6
UUOBK5: PUSH P,[$APPLYFRAME]
UUOBK6: MOVS R,40
HRRI R,CPOPJ
SKIPL UUOBKG ;MAYBE DON'T WANT THE CPOPJ
PUSH P,R
HRRZS UUOBKG
POP FXP,R
POP FXP,TT
JRST @UUOBKG
;UUOSBR UUOSB2 UUOSB3 UUOSB5 UUOSB6 UUOSB7 UUOSB4 UUOXT0 UUOXIT UUOXT1 UUOXCT UUOACS
UUOSBR: HLRZ T,(T) ;*** FSUBR CALLED LIKE FSUBR
MOVEM P,UUPSV
MOVNI R,1
TLOA A,400000
UUOSB2: MOVEI R,1 ;R>0 SAYS DON'T DO FRAME HACKERY
UUOSB3: MOVE TT,40 ;OTHERWISE R HAS -<# OF ARGS>
UUOSB5: TLO T,(PUSHJ P,)
TLNE TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
TLCA T,(JRST#<PUSHJ P,>)
PUSH P,UUOH
UUOSB6: JUMPG R,UUOSB7
EXCH T,R
JSR UUOBKG
EXCH T,R
UUOSB7: TLZ A,-1
TLNE TT,(20←33) ;THE NUMERIC CALL BIT. SEE DEFINITION OF NCALL
AOS T ;FOR NCALL, ENTER AT ENTRY+1
SKIPN VNOUUO
TLNE TT,(2←33) ;THE NO-CLOBBER BIT. SEE DEFINITION OF CALLF
JRST UUOXT0
SOS TT,UUOH
UUOSB4: LDB R,[331100,,(TT)]
CAIN R,XCT←-33
JRST UUOXCT ;MAKE XCT OF UUO WORK
MOVEM T,(TT)
UUOXT0: TLNN T,(34←33) ;CAUSE EXIT TO INDIRECT THRU ACALL
TLO T,(@)
UUOXIT: EXCH T,UUTSV
UUOXT1: MOVE TT,UUTTSV
MOVE R,UURSV
JRST @UUTSV
UUOXCT: LDB R,[220400,,(TT)] ;GET INDEX FIELD OF XCT
JUMPE R,.+2
HRRZ R,@UUOACS-1(R) ;IF NON-ZERO, GET CONTENTS OF THAT AC
ADD R,(TT) ;ADD IN ADDRESS FIELD
HLL R,(TT)
MOVEI TT,(R)
TLNE R,(@)
JRST UUOXCT ;MAKE INDIRECTION WIN
JRST UUOSB4 ;MAKE XCT OF XCT ... OF XCT OF UUO WIN
;;; TABLE OF WHERE TO FIND THE ACS AS THEY WERE ON UUO ENTRY
UUOACS:
IRPS X,,[A B C AR1 AR2A UUTSV UUTTSV D UURSV F FREEAC UUPSV FLP FXP SP]
X
TERMIN
;UUOARR UUOS0 UUOS03 UUOAR2 UUONVL FIX7 UUOS1E UUOS2E UUOE3
UUOARR: HLRZ R,(T) ;*** ARRAY CALLED LIKE SUBR
MOVSI TT,(@)
JRST UUOS03
UUOS0: SETZ TT, ;*** SUBR CALLED LIKE SUBR
HRRZ R,UUOFN
UUOS03: MOVEM P,UUPSV ;THIS IS TO HELP UUOXCT
HLR TT,(T)
PUSH P,TT
LDB T,[270400,,40]
MOVNS T
PUSH FXP,T
PUSHJ P,ARGCHK ;SKIPS IF OK
JRST UUOS0E
POP FXP,R ;R NOW HAS -<# OF ARGS>
POP P,T
TLNN T,(@) ;FURTHER WORK NEEDED FOR CALLING AN ARRAY
JRST UUOSB3
MOVSI TT,TTS<CN>
HLL A,40 ;UUOSB7 WILL CLEAR LEFT HALF OF A
TLNN A,2000 ;DO NOT SET THE COMPILED-CODE-
IORM TT,TTSAR(T) ; NEEDS-ME BIT FOR A CALLF!
MOVE TT,40
TLZN TT,(20←33)
JRST UUOSB3
TLNN TT,(2←33)
JRST UUOAR2 ;NCALL'ING AN ARRAY MEANS CLOBBER,
PUSH P,[UUONVL] ; IF ANY, SHOULD BE TO ACALL
JRST UUOSB5
UUOAR2: TLNN TT,1000
TLOA T,(ACALL) ;NCALL, BUT NOT NCALLF => ACALL
TLOA T,(AJCALL) ;NJCALL, BUT NOT NJCALF => AJCALL
PUSH P,UUOH
TLZ TT,777000
TLZ T,(@)
JRST UUOSB6
UUONVL: SKOTT A,FX+FL
JRST UUONVE
FIX7: MOVE TT,(A) ;OF COURSE, THE ROUTINE HAD BETTER COME UP
POPJ P, ;WITH SOME LISP NUMBER AS VALUE
UUOS1E: PUSH FXP,D
MOVEI D,1
JRST UUOE3
UUOS2E: MOVEM D,(FXP) ;TAKE THE SPOT ALREADY PUSHED ON FXP
MOVEI D,3
UUOE3: PUSHJ P,SAVX3 ;ARGS WERE ALREADY ON PDL, HENCE MUST BE POPPED OFF
MOVEM B,QF1SB ;SO WE MIGHT AS WELL LIST THEM UP WHILE WE'RE AT IT
PUSH FXP,T
PUSHJ FXP,LISTX
POP FXP,T
MOVE B,QF1SB
JRST UUOE2
;UUOS0E UUOS0F UUOE2 UUOSE1 UUOS1
UUOS0E: SUB P,R70+1
UUOS0F: PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,0
UUOE2: TLNE D,2 ;D 1.2 => EXIT ADDRESS ALREADY BEEN HACKED
JRST .+4
MOVE R,40
TLNN R,1000
PUSH P,UUOH
PUSHJ FXP,SAV5M1
PUSH P,[UUOSE1]
MOVE TT,40
HRLS TT
PUSH P,TT ;NAME OF FUNCTION IN LH
TRNN D,1 ;1.1 => LISTING HAS ALREADY BEEN DONE
JSP TT,ARGP0 ;ARGS TO FUNCTION NOW ON PDL
MOVEM D,-1(FXP)
PUSHJ P,RSTX3 ;RECUPERATE - IF POSSIBLE, DO NEW EVALUATION
JRST WNAERR ;OR ELSE CRAP OUT ON WRONG NUMBER ARGS
UUOSE1: PUSHJ FXP,RST5M1
POP FXP,D
POPJ P,
UUOS1: HRRZ TT,(T) ;*** SUBR CALLED LIKE LSUBR
HLRZ T,(T)
EXCH T,UUTSV
JSP R,PDLARG
HRRZ R,UUOFN
PUSHJ P,ARGCK0 ;FORCE CHECKING OF NUMBER OF ARGS
JRST UUOS0F
MOVE TT,40
TLNE TT,(20←33) ;THE NCALL BIT
AOS UUTSV
TLNN TT,(1←33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL
PUSH P,UUOH
JSR UUOBKG
JRST UUOXT1
;UUOX4B UUOLSB UUOLB3 UUOLB4 UUOFUL
UUOX4B: SKIPN UUOH ;=0 MEANS ENTRY FROM MAP SERIES
JRST (R)
PUSHJ FXP,SAV5M1
PUSH P,CR5M1PJ
JRST (R)
UUOLSB: MOVEM P,UUPSV ;*** LSUBR CALLED LIKE LSUBR
MOVEI A,NIL
HLRZ T,(T)
SKIPN V.RSET
JRST UUOSB2
PUSH FXP,T ;SAVE T (ADDRESS OF LSUBR)
MOVE T,UUTSV
PUSH FXP,T ;SAVE -<# OF ARGS> FOR UUOFUL
HRRZ R,UUOFN ;FOR ARGCK0
PUSHJ P,ARGCK0
JRST UUOS1E
MOVE R,T ;WATCH THIS SHUFFLING OF R, T, AND UUTSV!
JSP T,NPUSH-6 ;SIX SLOTS FOR "APPLY FRAME", ETC.
MOVE T,UUTSV
MOVEM R,UUTSV
MOVEI T,(P)
UUOLB3: AOJG R,UUOLB4 ;SO SLIDE STUFF SIX SLOTS UP THE PDL
MOVE TT,-6(T) ;AT END, T POINTS TO LAST OF THE FIVE
MOVEM TT,(T) ; FRAME SLOTS FOR UUOFUL
SOJA T,UUOLB3
UUOLB4: MOVE TT,40 ;FIGURE OUT IF CALL OR CALLF TYPE
MOVEI R,CPOPJ ; (MAY BE CALL TYPE IF 0 ARGS)
TLO R,(PUSHJ P,) ;FIGURE IT OUT
TLNE TT,1000 ;IT MAY LOOK LIKE WE'RE CONSTRUCTING A PUSHJ
TLCA R,(JRST#<PUSHJ P,>) ; TO THE WRONG PLACE, BUT READ THIS CAREFULLY!
HRR R,UUOH ;RETURN ADDRESS MUST GO UNDER
HRRZM R,-5(T) ; THE FRAME, NOT OVER!!!
HLLM R,-1(FXP) ;SAVE INSTRUCTION TO CLOBBER WITH
MOVEI TT,(T)
PUSHJ P,UUOFUL ;SO STICK AN APPLY FRAME UNDER ARGS, IF ANY
;REMEMBER, UUOFUL EXPECTS TWO FROBS
; ON FXP, AND POPS ONE OF THEM
POP FXP,T ;RESTORE T (ADDRESS OF LSUBR)
MOVE TT,40
JRST UUOSB7
UUOFUL: MOVS R,40 ;PUT FRAME UNDER LSUBR CALL
HRRI R,CPOPJ ;TT POINTS TO LAST OF 5 PDL SLOTS
MOVEM R,(TT) ;USES T,TT,R
MOVEI R,-2(FXP) ;FXP HAS -<# OF ARGS> AND ONE
HRRM R,-3(TT) ; OTHER SLOT AS WELL
HRLM FLP,-3(TT)
HRLM SP,-2(TT)
HRRZ R,40
HRRM R,-2(TT)
POP FXP,T
MOVEI R,(T)
HRLI R,-1(T)
ADDI R,(P)
SKIPN T
SETZ R,
MOVEM R,-4(TT)
MOVE R,[$APPLYFRAME]
MOVEM R,-1(TT)
POPJ P,
;UUOS9 UUOS7 UUOS7A UUOS7H UUOS7K
UUOS9: SKIPA TT,CILIST ;*** LSUBR CALLED LIKE FSUBR
UUOS7: MOVEI TT,ARGPDL ;*** LSUBR CALLED LIKE SUBR
MOVE R,40
TLNN R,1000
PUSH P,UUOH
HLRZ T,(T)
TLNE R,(20←33) ;THE NCALL BIT
ADDI T,1
PUSH FXP,T
PUSH FXP,XC-1
SKIPN V.RSET
JRST UUOS7A
MOVEI T,1
PUSHJ P,UUOBAK
REPEAT 2, SOS -3(P) ;ALLOW FOR TWO FROBS ON FXP
HRRZM P,(FXP)
UUOS7A: JSP TT,(TT) ;ARGPDL OR ILIST
POP FXP,R
JUMPL R,UUOS7K
SKIPN TT,T
JRST UUOS7H
HRLI TT,-1(TT)
ADDI TT,1(P)
UUOS7H: MOVEM TT,-4(R)
MOVE TT,[$APPLYFRAME]
MOVEM TT,-1(R) ;APPLYFRAME DONE
UUOS7K: MOVEM T,UUTSV
HRRZ R,UUOFN
PUSHJ P,ARGLCK
JRST UUOS2E
POP FXP,T
MOVEI A,0
JRST UUOXIT
;UUOS2A UUOS2 UUOS2Q CILIST UUOS1A
UUOS2A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE FSUBR
MOVEM TT,LISAR
MOVEI R,(TT)
MOVEI TT,IAPAR1
JRST UUOS2Q
UUOS2: HLRZ TT,(T) ;*** SUBR CALLED LIKE FSUBR
HRRZ R,UUOFN
UUOS2Q: MOVE T,40
TLNN T,1000
PUSH P,UUOH
TLNE T,(NCALL)
PUSH P,[UUONVL]
CAIN T,IAPAR1
PUSH P,LISAR
PUSH FXP,TT ;SUBR ADDR
CILIST: JSP TT,ILIST ;ILIST FORTUNATELY SAVES R
PUSHJ P,ARGCHK
JRST UUOS2E
JSP R,PDLARG
POP FXP,TT ;PRESERVE T FOR UUOBKG
CAIN TT,IAPAR1
POP P,LISAR
JSR UUOBKG
MOVEI T,(TT) ;BEWARE! LOOSE SUBR POINTER
JRST UUOXIT
UUOS1A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE LSUBR
MOVEM TT,LISAR
MOVEI T,IAPAR1 ;HAIR SO INTERRUPTS WON'T SCREW US
EXCH T,UUTSV
JSP R,PDLARG ;SAVES TT
JSR UUOBKG ;ALSO SAVES TT, AND WANTS NOTHING ON PDLS
LDB R,[TTSDIM,,TTSAR(TT)]
MOVE TT,40
TLNN TT,1000
PUSH P,UUOH
TLNE TT,(NCALL)
PUSH P,[UUONVL]
MOVNI R,(R)
CAMN R,T
JRST UUOXT1
PUSH FXP,D
PUSHJ P,SAVX3
MOVEI D,2
JRST UUOE2
;UUOS4 UUF2N UUOS6 UUOS6Q UUOS11
;;; PUTCODE [EXPR ← FSUBR]40
UUOS4: POP P,A ;*** FEXPR CALLED LIKE LSUBR
MOVN TT,UUTSV
JRST UUOS4A
UUF2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE FSUBR
UUOS6: HLRZ TT,(T) ;*** EXPR CALLED LIKE FSUBR
MOVE R,40
TLZN TT,-1 ;UUF2N LEAVES LH OF T ↑= 0
HRL TT,R ;OTHERWISE GET SUBR EXPR NAME IN LH
TLNN R,1000
PUSH P,UUOH
TLNE R,(20←33) ;THE NCALL BIT
PUSH P,[UUONVL]
JSP R,UUOX4B
SKIPN V.RSET
JRST UUOS6Q
PUSH P,FXP ;IF IN *RSET MODE, MAKE
HRLM FLP,(P) ; UP AN EVAL FRAME (SEE EVAL
MOVEI C,(A) ; FOR FORMAT THEREOF)
HRRZ B,40
PUSHJ P,XCONS ;MUST CONS UP FAKE ARG TO EVAL
PUSH P,A
HRLM SP,(P)
PUSH P,[$EVALFRAME]
MOVEI A,(C)
UUOS6Q: PUSH P,TT ;PUSH OF FUNCTION
MOVEI TT,IAPPLY
JRST ILIST
UUOS11: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE LSUBR
MOVE T,UUTSV
JRST UUS10A
;;; ENDCODE [EXPR ← FSUBR]
;UUOS3 UUOS4A UUOEX2 UUOS UUOEXP UUOEX4 UUOS10 UUS10A
UUOS3: LDB TT,[270400,,40] ;*** FEXPR CALLED LIKE SUBR
UUOS4A: SOJN TT,UUOFER
UUOEX2: MOVEI TT,1 ;*** FEXPR CALLED LIKE FSUBR
DPB TT,[270400,,40]
TLOA A,400000
UUOS: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE SUBR
UUOEXP: HLRZ TT,(T) ;*** EXPR CALLED LIKE SUBR
LDB T,[270400,,40]
UUOEX4: MOVE R,40 ;ALL OF T,TT,R WILL BE LOST!
TLZN TT,-1 ;INSERT EXPR NAME IF WAS EXPR
HRL TT,R
TLNN R,1000
PUSH P,UUOH
MOVN T,T
SKIPE V.RSET
PUSHJ P,UUOBNC
TLNE R,(NCALL)
PUSH P,[UUONVL]
JSP R,UUOX4B
PUSH P,TT ;PUSH FUNCTION
JUMPE T,IAPPLY
MOVEM T,UUTSV
HRLZ R,UUTSV
MOVE A,1(R)
JSP T,PDLNMK
PUSH P,A ;PUSH ARGUMENT
AOBJN R,.-3
MOVE T,UUTSV
JRST IAPPLY ;APPLY FUN TO ARGS
UUOS10: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE SUBR
JSP TT,ARGPDL
UUS10A: AOJN T,UUOFER
POP P,A
MOVSI T,2000
IORM T,40
MOVE T,UUOFN
JRST UUOSBR
;UUL2N UUOS5 UUOS5A UUOS5B UUOS5C
UUL2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE LSUBR
UUOS5: HLRZ TT,(T) ;*** EXPR CALLED LIKE LSUBR
MOVE T,UUTSV
CAMGE T,XC-NACS
JRST UUOS5A
JSP R,PDLARG
MOVNS T
JRST UUOEX4
UUOS5A: PUSH FXP,T ;DAMN CASE WHERE WE MUST
PUSH FXP,V.RSET ; SLIDE STUFF UP THE PDL,
MOVEI R,(P) ; DOING PDLNMK'S AS WE GO
JSP T,NPUSH-3-NACS+1 ;ROOM FOR ALL ACS BUT A, PLUS 3
SKIPE (FXP)
JSP T,NPUSH-5 ;EXTRA SLOTS FOR *RSET
MOVEI D,(P)
MOVE F,-1(FXP)
UUOS5B: MOVE A,(R) ;SO DO ALL THE PDLNMK'S
JSP T,PDLNMK
MOVEM A,(D)
SUBI R,1
SUBI D,1
AOJL F,UUOS5B
HRL TT,40 ;TT HAS BEEN SAVED - HAS FN
MOVEM TT,(D) ;SAVE FUNCTION BELOW ARGS FOR IAPPLY
SKIPE (FXP) ;D SHOULD POINT TO WHERE ACS ARE SAVED
SUBI D,5 ;FOR *RSET, MUST SAVE THE ACS UNDER THE FRAME!
REPEAT NACS-1, MOVEM B+.RPCNT,.RPCNT-NACS(D) ;SAVE ALL MARKED ACS BUT A
MOVEI TT,R5M1PJ ;PROVIDE FOR RESTORING THEM
MOVEM TT,-1(D) ;ACS WERE SAVED UNDER, NOT OVER, THE
MOVE TT,40 ; FRAME IN CASE OF AN FRETURN
MOVE F,UUOH ;MAYBE NEED RETURN ADDRESS UNDER
TLNE TT,1000 ; THE ARGS (IF NOT, USE A CPOPJ)
MOVEI F,CPOPJ
MOVEM F,-NACS-1(D)
POP FXP,F
JUMPE F,UUOS5C ;MAYBE MORE *RSET HAIR?
PUSH FXP,(FXP) ;DUPLICATE NUMBER OF ARGS ON FXP
MOVEI TT,4(D) ;TT POINTS TO THE FIVE *RSET SLOTS
MOVEM TT,-1(FXP) ;PLOP POINTER INTO PDL SLOT
PUSHJ P,UUOFUL ;SET UP APPLYFRAME (POPS FXP)
POP FXP,TT
HRRZS (TT) ;FLUSH CPOPJ - IAPPLY WILL CREATE ONE
JRST IAPPLY
UUOS5C: POP FXP,T ;NOW FOR THE IAPPLY
JRST IAPPLY ;UUOFUL WANTS TWO THINGS ON FXP, WILL POP ONE
;ARGCHK ARGLCK ARGCK1 ARGCK2 ARGCK0 ARGCK4 ARGCK3 ARGCK5 ARGPDL ARGP0 ARGP1 PDLARG PAERR PDLA2
ARGCHK: CAMGE T,XC-NACS ;CHECK NUMBER OF ARGS SUPPLIED
JRST PAERR ;R HAS ATOM PROPERTY LIST POINTER
ARGLCK: SKIPE V.RSET
JRST ARGCK2
ARGCK1: POP P,TT ;FOR SPEED, DO THIS RATHER THAN
JRST 1(TT) ;AOS (P) POPJ P,
ARGCK2: SKOTT R,SY ;R HAS SYMBOL OR SAR
JRST ARGCK5 ;MUST BE A SAR
ARGCK0: HLRZ R,(R)
HLRZ R,1(R)
JUMPE R,ARGCK1
LDB TT,[111100,,R]
JUMPN TT,ARGCK3
ARGCK4: LDB TT,[001100,,R]
MOVNI TT,-1(TT)
CAMN T,TT
AOS (P)
POPJ P,
ARGCK3: MOVNI TT,-1(TT)
CAMLE T,TT
POPJ P,
LDB TT,[001100,,R]
CAIN TT,777 ;777 IS EFFECTIVELY INFINITY
JRST POPJ1
MOVNI TT,-1(TT)
CAML T,TT
AOS (P)
POPJ P,
ARGCK5: LDB R,[TTSDIM,,TTSAR(R)]
AOJA R,ARGCK4
ARGPDL: LDB T,[270400,,40] ;ARGS => PDL -CNT=> T
MOVNS T
ARGP0: HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
PDLARG: CAMGE T,XC-NACS
PAERR: LERR EMS16 ;MORE THAN 5 ARGS
JRST .+1+NACS(T)
REPEAT NACS,[CONC RSTR,\<A-1+NACS-.RPCNT>,: POP P,A-1+NACS-.RPCNT
]
PDLA2: JRST (R)
MOVEI D,QSUBRCALL ;COME HERE IF SUBRCALL (Q.V.) GOT 0 ARGS
SOJA T,WNALOSE
;STRTOUT ERP0E ERP0F ERP0A ERBPLOC ERP1 ERP5 ERP5A ERP0D ERP0C ERP3 ERP4 ERP6 ERP6A ENDFUN
STRTOUT:
MOVE T,UUTSV
PUSH P,UUOH
PUSH P,A
PUSHJ P,SAVX5
PUSH FXP,40
PUSH P,AR1
PUSH P,AR2A
LDB D,[270400,,(FXP)] ;AC=17 MEANS USE MSGFILES.
CAIN D,17
JRST ERP0D
SKIPN AR1,(D) ;NIL MEANS USE DEFAULT ↑R AND ↑W
JRST ERP0C
CAIN AR1,QUNBOUND ;GIVEN UNBOUND VARIABLE?
LERR [SIXBIT \UNBOUND VARIABLE IN PRINC FROM COMPILED CODE --GSB!\]
ERP0E: TLO AR1,200000
ERP0F: MOVEI A,(AR1)
LSH A,-SEGLOG
SKIPL ST(A) ;MAYBE SHOULD ERRR-CHECK BETTER?
TLO AR1,400000 ;NOTE WHETHER LIST OR NOT
ERP0A: JSP T,GTRDTB
.5LOCKI
ERBPLOC==-1 ;LOCATION OF BYTE PTR ON FXPDL
MOVSI D,440600
HLLM D,ERBPLOC(FXP)
ERP1: ILDB TT,ERBPLOC(FXP) ;STRING BYTE POINTER IS STORED ON FXP
CAIN TT,'# ;THE .5LOCKI SAVED INHIBIT ON TOP OF FXP
JRST ERP3
CAIN TT,'!
JRST ERP6
CAIN TT,'↑
JRST ERP4
ERP5: ADDI TT,40
ERP5A: PUSHJ P,STRTYO
JRST ERP1
ERP0D: SKIPN AR1,VMSGFILES
JRST ERP6A
JRST ERP0E
ERP0C: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
JUMPN AR1,ERP0F
SKIPE TTYOFF
JRST ERP6A
JRST ERP0A
ERP3: ILDB TT,ERBPLOC(FXP) ;QUOTE A CHAR
JRST ERP5
ERP4: ILDB TT,ERBPLOC(FXP) ;CONTROLLIFY A CHAR
ADDI TT,40
TRC TT,100
CAIE TT,↑M
JRST ERP5A
PUSHJ P,STRTYO
MOVEI TT,↑J
JRST ERP5A
ERP6: UNLOCKI ;DONE!
ERP6A: POP P,AR2A
POP P,AR1
SUB FXP,R70+1 ;FLUSH BYTE PTR
POP P,A ;RESTORE A
JRST RSTX5 ;RESTORE NUMACS AND POPJ
ENDFUN==.-1 .SEE SSYSTEM ;NO MORE FUNCTIONS BEYOND HERE
;LISP LISP17 LIHAC
SUBTTL INITIAL STARTUP CODE
;;; NORMAL ≠G STARTUP CODE. ON FIRST RUN, THE ALLOC PHASE COMES HERE;
;;; THEREAFTER, LISPGO COMES HERE DIRECTLY.
;;; WE DO NOT HAVE THE USE OF THE PDLS UNTIL THE CALL TO ERINIX.
;;; WE DO NOT HAVE THE USE OF CONSING OF ANY SORT UNTIL THE CALL TO GCNRT.
LISP:
;CLEAR AND DISABLE INTERRUPT SYSTEM
IFN ITS,[
PION
.SUSET [.SPIRQC,,R70]
.SUSET [.SIFPIR,,R70]
.SUSET [.ROPTION,,TT]
TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE
.SUSET [.SOPTION,,TT]
TLNN TT,OPTBRK ;IF OUR SUPERIOR CLAIMS TO HANDLE BREAKS,
JRST LISP17 ; AND IF IT CLAIMS TO HAVE LISP'S SYMBOL TABLE
.BREAK 12,[..RSTP,,TT] ; VALRET A STRING TO CAUSE ≠& TYPEOUT MODE
SKIPGE TT ; TO BE S-EXP TYPEOUT (AND ≠% TO BE SQUOZE)
.VALUE [ASCIZ /↔:IF N :SYMTYP P%
≠(..TAMP\
..TPER\≠1Q
..TAMP\P%
≠):VP /]
LISP17:
] ;END OF IFN ITS
PION ;ENABLE INTERRUPTS
;CONSIDER SHARING PAGES WITH OTHER JOBS
IFN USELESS*ITS, JSP T,SHAREP
;RESET I/O SWITCHES
SETZM TAPWRT ;UWRITE FLAG (↑R)
SETZM TTYOFF ;TTY OUTPUT FLAG (↑W)
IFN JOBQIO,[
IT$ .DTTY ;SAY THIS JOB WANTS THE TTY, RATHER
IT$ JFCL ; THAN LETTING AN INFERIOR HAVE IT
IT% WARN [RETRIEVE TTY FROM INFERIOR?]
] ;END OF IFN JOBQIO
;RESET FREELISTS TO FORCE A CLEAN GARBAGE COLLECTION
REPEAT NFF, SETZM FFS+.RPCNT ;SET FREELISTS TO NIL
IFN HNKLOG+DBFLAG+CXFLAG, MOVSI A,(SETZ)
IFN HNKLOG,[
REPEAT HNKLOG+1,[
SKIPN HNSGLK+.RPCNT ;HACK TO AVOID CREATING
MOVEM A,FFH+.RPCNT ; UNNEEDED HUNK SEGMENTS
] ;END OF REPEAT HNKLOG+1
] ;END OF IFN HNKLOG
DB$ SKIPN DBSGLK ;DITTO FOR WEIRD NUMERIC TYPES
DB$ MOVEM A,FFD ;THE SETZ BIT IN THE FREELIST
CX$ SKIPN CXSGLK ; POINTER MEANS IT IS OKAY TO
CX$ MOVEM A,FFC ; HAVE NO FREE CELLS AS LONG AS
DX$ SKIPN DXSGLK ; NO ONE TRIES TO CONS ONE
DX$ MOVEM A,FFZ
SETZM GCTIM ;RESET GC TIME (SINCE RUNTIME PROBABLY GOT RESET?)
SETZM ALGCF ;RESET ALLOC FLAG - OKAY TO GC NOW
JSP T,TLVRSS ;RESET VARIOUS "TOP LEVEL VARIABLES"
JSP A,ERINIX ;SET UP PDLS, RESTORE MUNGED DATA, ENABLE INTERRUPTS
20$ JSP T,TNXSET ;DECIDE WHICH OPSYS - TENEX OR TOPS20
; AND FIX UP PAGE ACCESSIBILITYS
;INITIALIZE DEFAULT DIRECTORY NAMES
IFN ITS,[
MOVE TT,IUSN
MOVEM TT,TTYIF2+F.SNM
MOVEM TT,TTYOF2+F.SNM
] ;END OF IFN ITS
IFN D10,[
SA% GETPPN T, ;FOR TOPS10/CMU, USE GETPPN
SA% JFCL ; (GETS PPN OF CURRENT JOB)
SA$ SETZ T, ;FOR SAIL, WE PREFER DSKPPN
SA$ DSKPPN T, ; (AS SET BY THE ALIAS COMMAND)
MOVEM T,USN
] ;END OF IFN D10
;TRY TO OPEN THE TERMINAL AS AN I/O DEVICE
PUSHJ P,OPNTTY
JFCL
;PERFORM INITIAL GARBAGE COLLECTION (BUT DON'T BOTHER TO COMPACT ARRAYS)
MOVSI T,111111
PUSHJ P,GCNRT
;INITIALIZE THE NAME OF THE MACHINE IN THE FEATURES LIST
IFN ITS,[
.CALL LISP43 ;GETS NAME OF ITS (AI, MC, ML, DM) IN TT
.VALUE
PUSHJ P,SIXATM ;CONVERT TO ATOMIC SYMBOL
HRLM A,MACHFT ;SET UP (STATUS FEATURES) FOR MACHINE NAME
] ;END OF IFN ITS
MOVE TT,BPSH ;IF BPEND SOMEHOW
CAMGE TT,@VBPEND ; IS LARGER THAN BPSH,
PUSHJ P,BPNDST ; SET IT EQUAL TO BPSH
10$ PUSHJ P,SIXJBN ;INITIALIZE TEMP FILE NAME D10NAM
;INITIALIZE (STATUS UDIR)
IFN D10,[
IFE SAIL,[
MOVNI T,1 ;FOR NON-SAIL, TRY TO GET
SETZB TT,D ; DEFAULT SNAME BY USING PATH.
MOVEI R,0
MOVE F,[4,,T]
PATH. F,
] ;END OF IFE SAIL
MOVE D,USN ;ON FAILURE, JUST USE USN
MOVE TT,D ;PPNATM EXPECTS PPN TO BE IN AC TT
PUSHJ P,PPNATM
] ;END OF IFN D10
IFN ITS,[
MOVE TT,IUSN ;TAKE INITIAL SNAME
PUSHJ P,SIXATM ;CONVERT TO ATOMIC SYMBOL
] ;END OF IFN ITS
IFN D20,[
JSP T,TNXUDI ;GET THE CONNECTED DIRECTORY NAME IN PNBUF
PUSHJ P,PNBFAT ;CONVERT PNBUF TO AN ATOM
] ;END IFN D20
MOVEM A,SUDIR
;INITIALIZE CURRENT UNIT
;INITIALIZE VARIOUS BIZARRE TOP-LEVEL VARIABLES
MOVEI T,INR70 ;LOCATION OF LAP CONSTANTS
MOVEM T,VTTSR
MOVEI A,Q. ;INITIAL VALUE OF * IS *
MOVEM A,V.
MOVE A,VERRLIST ;SET UP FOR EVAL'ING ERRLIST
MOVEM A,VIQUOTIENT
SKIPGE AFILRD
JRST LSPRET
LIHAC: SETOM AFILRD ;HAIRY HAC TO READ, THE FIRST TIME
MOVEI A,TRUTH ; AROUND, FROM THE .LISP. (INIT) FILE
MOVEM A,TAPRED ;(SETQ ↑Q T)
JRST HACENT
;LISP43 SYMFIL TNXSET TNXST0 TNXST3 TNXST1 TNXST2 TNXUDI TNXUD0 TNXUD3 TNXUD6 TNXUD5 TNXUD2 TNXU9P TNXU9D TNXST9 TNXDIE D10SET NFLSS SUSCON LISPGO GOL1 GOL2 FLSLSP FLSPA4 FLSPA5 FLSVAL FLSVA1 FLSADJ FLSMSK FLSPA6 FLSPA1 FLSPA3 FLSST FLSDIE NOSHARE SHAREP SHARP1 PURCHK SYSFIL SYSCHN PURPGS SHRL1 SHRL2 SHRL3 SHRL4 SHRLOD PDUMPL PURCKS PUROPN PUROP1 PUROP2 PURRWO PDUMP PURCHN PURSTI PURISP PURPTR NFLSE
IFN ITS,[
LISP43: SETZ
SIXBIT \SSTATU\
REPEAT 5, 2000,,TT ;IGNORE USELESS GARBAGE
402000,,TT ;MACHINE NAME
] ;END OF IFN ITS
10$ WAKTTY: JRST (T)
IFN D20,[
SYMFIL: BLOCK 40 ;WHERE SYMBOLS WERE SAVED AT INIT TIME
TNXSET: MOVE A,[112,,11] ;MUST BE CALLED WHEN INTERRUPTS ARE OFF
GETTAB A,
JRST TNXST9 ;LOSE IF WE CANT DECIDE!
LDB A,[061400,,A] ;3 FOR TENEX, 4 FOR TOPS-10
SUBI A,2
CAIE A,1
MOVEI A,NIL
MOVEM A,TENEXP
MOVEI D,2 ;CCOC2 BITS FOR ↑←
MOVEI A,QTOPS20
JUMPE A,.+3
MOVEI D,1
MOVEI A,QTENEX
DPB D,[100200,,CCOCW2]
HRLM A,OPSYFT
MOVEI TT,1←17.-SEGSIZE+1
TNXST0: MOVEI D,(TT)
LSH D,-SEGLOG ;GET SEGMENT NUMBER
HLL D,ST(D)
TLNE D,ST.$NX
JRST TNXST1
TLNE D,ST.PUR
JRST TNXST2
TNXST3: MOVES (TT)
TNXST1: SUBI TT,SEGSIZE
JUMPG TT,TNXST0
JRST (T)
TNXST2: MOVEI A,(D)
HRLI A,.FHSLF ;ALSO MAKE PURE PAGES UN-WRITEABLE
MOVSI B,(PA%RD+PA%EX)
SKIPE SAWSP
SPACS
JRST TNXST1
;;; CODE TO GET THE CONNECTED DIRECTORY NAME INTO THE PNBUF
TNXUDI: MOVE TT,[PNBUF,,PNBUF+1]
SETZM PNBUF ;CLEAR PNBUF
BLT TT,PNBUF+LPNBUF-1
LOCKI
GJINF ;GET JOB INFORMATION
MOVE 1,PNBP ;POINTER INTO PNBUF
DIRST ;GET EQUIVALENT ASCII STRING
JRST TNXU9D ;HMM...
MOVE 1,PNBP
TNXUD0: ILDB D,1 ;SCAN DEVICE-NAME PART
CAIN D,0
JRST TNXUD2 ;WIN! NOT PUNCTUATION ANYWAY!
CAIE D,↑V
CAIE D,":
JRST TNXUD0
ILDB D,1
CAIE D,"<
JRST TNXU9P
MOVE 2,PNBP
TNXUD3: ILDB D,1 ;TRANSFER DIRECTORY-NAME PART
CAIN D,0
JRST TNXU9P
CAIE D,↑V
JRST TNXUD5
IDPB D,2
ILDB D,1
TNXUD6: IDPB D,2
JRST TNXUD3
TNXUD5: CAIE D,">
JRST TNXUD6
MOVEI D,0
MOVEI A,9
IDPB D,2 ;PAD LIKE ASCIZ WITH AN EXTRA WORD OF 0'S
SOJG A,.-1
TNXUD2: SETZB 1,2
UNLOCKI
JRST (T)
TNXU9P: MOVE 1,[440700,,[ASCIZ \Punctuated string in PNBUF loses in TNXUDI\]]
JRST TNXDIE
TNXU9D: SKIPA 1,[440700,,[ASCIZ \DIRST loses in TNXUDI\]]
TNXST9: MOVE 1,[440700,,[ASCIZ \GETTAB loses in TNXSET\]]
TNXDIE: PSOUT
HALTF
] ;END OF IFN D20
IFN D10*<1-SAIL>,[
D10SET: MOVNI TT,1 ;AOBJN ON -1 LEAVES [1,,0] ON A KA10
AOBJN TT,.+1 ; BUT [0] ON A KL OR KI
MOVEM TT,KA10P
SETZM MONL6P
MOVE A,[%CNMNT] ;GET MONITOR TYPE WORD
GETTAB A,
MOVEI A,010000 ;ASSUME TOPS-10 IF GETTAB ENTRY NOT THERE
LDB A,[.BP CN%MNT,A] ;1 = TOPS-10, 2 = ITS, 3 = TENEX, 6 = TOPS-20
SOJE A,.+3 ;REAL TOPS-10 SYSTEM, RATHER THAN SIMULATOR?
SETZB A,SGANAM ; ON VARIOUS SIMULATIONS, DONT KILL HISEG
JRST .+7
MOVE A,[%CNVER]
GETTAB A, ;GET MONITOR LEVEL NUMBER
MOVSI A,5
LDB A,[220600,,A]
CAIN A,6
SETOM MONL6P
JRST (T)
] ;END OF D10*<1-SAIL>
;NOTHING ON THIS PAGE IS FLUSHED WHEN/IF LISP'S PURE PAGES ARE CLEARED FROM
; CORE DURING A SUSPEND
NFLSS::
20$ ENTVEC: JRST LISPGO ;TOPS-20 ENTRY VECTOR
;;; HERE IF NOT STOPPING AFTER A SUSPEND
SUSCON: MOVEI A,TRUTH ;RETURN T RATHER THAN NIL
MOVEM A,-1(FLP)
;;; FALL INTO LISPGO
LISPGO: SETOM AFILRD ;START HERE ON ≠G'ING
IT$ .SUSET GOL1 ;SET .40ADDR
IT$ .SUSET GOL2 ;GET INITIAL SNAME
20$ RESET ;RESET OURSELVES ON STARTUP
JRST 2,@LISPSW ;ZEROS OUT PC FLAGS, AND TRANSFERS TO LISP
IFN ITS,[
GOL1: .S40ADDR,,.+1
TWENTY,,FORTY
GOL2: .RSNAM,,IUSN
FLSLSP: .CALL SYSFIL ;IN ORDER TO FLUSH PAGES, WE MUST BE CERTAIN
JRST FLSNOT ; THAT WE CAN GET OURSELVES BACK!
.CLOSE TMPC,
.CALL PURCHK ;ONLY FLUSH IF LISP IS PURE
.VALUE
JUMPLE TT,FLSNOT
SETOM SAWSP ;FLAG THAT WE MUST READ OURSELVES FROM THE FILE
MOVE T,[440100,,FLSTBL] ;POINTER INTO TABLE OF WHICH PAGES TO FLUSH
SETZI TT, ;KEEP PAGE NUMBER IN TT
FLSPA4: ILDB R,T ;GET INFO ON THIS PAGE
JUMPE R,FLSPA5 ;SKIP IF NOT FLUSHABLE
CAIE TT,NFLSS/PAGSIZ ;NEVER FLUSH THE PAGES WE ARE ON
CAIN TT,NFLSE/PAGSIZ
JRST FLSPA5
.CALL FLSPA6 ;ELSE FLUSH THE PAGE FROM OUR PAGE MAP
.LOSE 1400
FLSPA5: CAIGE TT,777777/PAGSIZ ;LOOP UNTIL HIGHEST PAGE NUMBER
AOJA TT,FLSPA4
.SUSET FLSMSK ;MAKE SURE NO INTERRUPTS TRY TO HAPPEN
PUSHJ P,PDUMPL ;PURE DUMP LISP IF SO DESIRED
SKIPE (FLP) ;NIL JCL?
JRST SUSCON ;NOPE, RETURN T AND PROCEED
SKIPE TT,(FXP) ;CHECK IF VALRET STRING
JRST FLSVAL ;YES, MUST VALRET IT THEN
MOVE T,FXP
SUB T,FLSADJ
MOVEM T,(FXP)
.VALUE FLSPA1 ;PRINT SUSPENSION MESSAGE
JRST SUSCON ;CONTINUING AFTER A SUSPEND
FLSVAL: SKIPN VALFIX ;IS VALRET STRING REALLY A FIXNUM?
JRST FLSVA1 ;NO, USE NORMAL VALRET
HRRZ T,1(TT) ;PICKUP THE VALUE
.BREAK 16,(T) ;DO THE .BREAK
JRST SUSCON ;CONTINUE WHEN IT RETURNS, BUT RETURN T
FLSVA1: .VALUE 1(TT)
JRST SUSCON ;ON PROCEED, RETURN T
FLSADJ: 1,,1
FLSMSK: .SMASK,,.+1
0,,0
FLSPA6: SETZ
SIXBIT \CORBLK\
MOVEI 0 ;FLUSH THE PAGE
MOVEI %JSELF ;FROM OURSELVES
SETZ TT ;PAGE NUMBER IN TT
FLSPA1: ASCIZ \:≠Suspended≠
\
FLSPA3: ASCIZ \:≠LISP pure pages flushed, and job Suspended≠
\
FLSST: .CALL SYSFIL ;TRY TO FIND THE LISP
.VALUE FLSDIE ;DIE, DIE, DIE
JSP T,SHARP1 ;BEFORE STARTING MUST HAVE A REAL CORE IMAGE
SETZM SAWSP ;WE HAVE ALREADY MAPPED OURSELVES IN
JRST SUSP3
FLSDIE: ASCIZ \:≠LOSE!! CANNOT FIND PURQIO THAT THIS LISP WAS DUMPED FROM!≠
\
NOSHARE==JRST (T) ;DEPOSIT INTO SHAREP TO INHIBIT SHAREING
SHAREP: SKIPN SAWSP
JRST (T)
SETZM SAWSP
.CALL PURCHK
.VALUE
JUMPLE TT,(T)
.CALL SYSFIL
JRST (T)
SHARP1:
IFN 0,[
;THIS IS THE OLD CODE TO READ IN FROM THE DISK FILE.
.ACCESS TMPC,SHRL1
MOVE TT,SHRL2
.CALL PURPGS ;SHARE PURE CODE
.VALUE
.ACCESS TMPC,SHRL3
MOVE TT,SHRL4
.CALL PURPGS ;SHARE PURE DATA AREAS
.VALUE
] ;END IFN 0
IFN 1,[
.CALL SHRLOD ;LOAD ALL PURE PAGES FROM THE FILE
.LOSE 1400
] ;END IFN 1
.CLOSE TMPC,
JRST (T)
PURCHK: SETZ
SIXBIT \CORTYP\ ;GET TYPE FOR CORE BLOCK
1000,,PURCHK/PAGSIZ ;THE PAGE WE ARE ON
402000,,TT ;>0 READ-ONLY, <0 WRITABLE
SYSFIL: SETZ ;FOR OPENING UP FILE TO SHARE
SIXBIT \OPEN\
SYSCHN
SYSDEV
SYSFN1
SYSFN2
SETZ SYSSNM
SYSCHN: .UII,,TMPC
PURPGS: SETZ
SIXBIT \CORBLK\ ;HACK CORE BLOCKS
1000,,200000 ;GET READ-ONLY PAGES
1000,,-1 ;PUT THEM INTO *MY* PAGE MAP
,,TT ;AOBJN POINTER FOR PAGES, OR PAGE NUMBER
401000,,TMPC ;DISK FILE TO SHARE WITH
IFN 0,[
SHRL1: 2000+BPURPG
SHRL2: -NPURPG,,BPURPG/PAGSIZ
SHRL3: 2000+BPURFS-<NXVCSG+NXXZSG>*SEGSIZ
SHRL4: -NPURFS,,BPURFS/PAGSIZ
] ;END IFN 0
IFN 1,[
SHRLOD: SETZ
SIXBIT \LOAD\
MOVEI %JSELF ;MYSELF
MOVEI TMPC ;CHANNEL ON WHICH PURQIO/PURBIB IS OPEN'ED
SETZI 0 ;LOAD ONLY PURE PAGES
] ;END IFN 1
;ROUTINE TO PDUMP A FILE WITH INDIRECT SYMBOL TABLE POINTER INCLUDED
PDUMPL: SKIPN PURDEV ;DID THE GUY WANT PURE DUMPING?
POPJ P, ;NOPE, RETURN RIGHT AWAY
.CALL PUROPN ;OPEN THE FILE FOR PDUMP'ING
.LOSE 1400 ;THE GUY LOST, OH WELL, WE ARE PROBABLY IN
; A SUSPEND ANYWAY
SETZ T, ;PDUMP REQUIRES AN INITALLY ZERO STATE WORD
.CALL PDUMP ;DO THE ACTUAL PDUMP
.LOSE 1400
.IOT TMPC,PURSTI ;OUTPUT START INSTRUCTION
.IOT TMPC,PURISP ;INDIRECT SYMBOL TABLE POINTER INDICATOR
MOVE TT,PURPTR ;POINTER TO FILENAMES
MOVE T,PURPTR ;START CHECKSUM
PURCKS: ROT T,1
ADD T,(TT) ;AND CHECKSUM FOR DDT
.IOT TMPC,(TT) ;ALSO OUTPUT THE WORD TO THE FILE
AOBJN TT,PURCKS
.IOT TMPC,T ;OUTPUT THE CHECKSUM
.IOT TMPC,PURSTI ;THEN AGAIN THE START ADR
.CALL PURRWO ;RENAME TO CORRECT FILENAME
.LOSE 1400
.CLOSE TMPC, ;FINISH UP WITH THE FILE
POPJ P,
PUROPN: SETZ
SIXBIT \OPEN\
PURCHN
PURDEV
PUROP1
PUROP2
SETZ PURSNM
PUROP1: SIXBIT \.LISP.\
PUROP2: SIXBIT \OUTPUT\
PURRWO: SETZ
SIXBIT \RENMWO\
MOVEI TMPC
PURFN1
SETZ PURFN2
PDUMP: SETZ
SIXBIT \PDUMP\
MOVEI %JSELF
MOVEI TMPC
SETZ T
PURCHN: .UIO,,TMPC
PURSTI: JRST LISPGO
PURISP: -4,,2
PURPTR: -4,,SYSDEV
NFLSE:
] ;END OF IFN ITS
;JCLSET JCST4 JCST2 JCST5 JCST1 JCST3
SUBTTL JCL INITIALIZATION ROUTINE
20$ WARN [D20 JCL?]
IFN D10,[
JCLSET: SETZ D,
MOVE R,[440700,,SJCLBUF+1]
SA% RESCAN
SA$ RESCAN A
SA% CAIA
SA$ SKIPN A
JRST JCST3
JCST4: INCHRS B
JRST JCST3
CAIE B,↑M ;IF <CR> OR <ALT> OCCURS ON COMMAND
CAIN B,33
JRST JCST3 ;BEFORE A ";", THEN NO JCL
CAIE B,";
CAIN B,"(
CAIA
JRST JCST4 ;LOOP UNTIL WE FIND A ; OR (
MOVNI D,BYTSWD*LSJCLBUF
JCST2: INCHRS A
JRST JCST1
CAIN B,"( ;IF JCL STARTED WITH A (,
CAIE A,") ; ONLY UP TO THE ) IS JCL,
CAIA ; BUT WE MUST GOBBLE THE WHOLE LINE
SETO B,
JUMPL B,JCST5
AOSG D
IDPB A,R
JCST5: CAIN A,↑M ;<CR> OR <ALT> TERMINATES
JRST JCST1 ;THE COMMAND LINE
CAIE A,33
JRST JCST2
JCST1: SKIPLE D
TDZA D,D ;TOO MUCH JCL => NONE AT ALL
ADDI D,BYTSWD*LSJCLBUF
JCST3: INCHRS A ;MAKE SURE NO SUPERFLUOUS CHAR
JFCL
MOVEM D,SJCLBUF
SETZ A,
IDPB A,R ;INSURE AT LEAST ONE NULL BYTE FOLLOWING THE LINE
JRST (F)
] ;END OF IFN D10
;SFXTBL SFXTBI PROTB
SUBTTL INTERNAL PCLSR'ING ROUTINES
SFXTBL: ;TABLE OF LOCATIONS FOR SFX HACK
MACROLOOP NSFC,ZZM,*
SFXTBI: ;TABLE OF INSTRUCTIONS NORMALLY IN THOSE LOCATIONS
MACROLOOP NSFC,ZZN,*
PROTB: ;TABLE OF INTERRUPT PROTECTION INTERVALS
MACROLOOP NPRO,PRO,*
;;; TABLE MUST BE AN EXACT POWER OF TWO IN LENGTH SO WE CAN
;;; USE SUPER-WINNING BINARY SEARCH METHOD.
HAOLNG LOG2NPRO,<.-PROTB-1>
REPEAT <1←LOG2NPRO>-NPRO,[ INTOK,,777777
] ;END OF REPEAT <1←LOG2NPRO>-NPRO
;;; IT IS OBVIOUSLY USELESS TO USE PROTECT MACROS BEYOND THIS POINT.
;;; EXPUNGING NPRO WILL CAUSE AN ERROR IF THE PROTECT MACROS ARE USED
EXPUNGE NPRO
;$IWAIT INTSFX SPWIN SPWIN1
;;; PUSHJ FXP,$IWAIT
;;; CALLED FROM WITHIN A NORMAL INTERRUPT HANDLER TO DECIDE
;;; WHETHER IT IS SAFE TO ISSUE A USER INTERRUPT.
;;; ON FAILURE, STACKS UP THE INTERRUPT AND SKIPS.
;;; AS FOR UINT0, D CONTAINS THE INTERRUPT DESCRIPTOR WORD.
;;; INTERRUPTS MUST BE DEFERRED; PDL OVERFLOW MUST BE
;;; ENABLED. THE CONTENTS OF INTPDL POINTS TO THE INTPDL ENTRY
;;; FOR THE CURRENT INTERRUPT, WHICH CONTAINS THE SAVED
;;; CONTENTS OF D AND R. FXP MUST BE IN A USABLE STATE.
$IWAIT: HLRZ R,NOQUIT ;IF IN GC, WE ARE IN A BAD STATE
JUMPN R,IWSTAK ; AND SO MUST STACK THE INTERRUPT
HRRZ R,INTPDL
CAIE R,INTPDL+LIPSAV ;FOR NESTED PI LEVEL (E.G. PDL OVERFLOW),
JRST IWSTAK .SEE INTXIT ; ALSO STACK THE INTERRUPT
MOVEI R,(SP) ;IF THE SPECPDL IS IN SOME
MOVE F,(SP) ; KIND OF STRANGE STATE (E.G.
CAME R,ZSC2 ; INTERRUPTED OUT OF SPECBIND)
CAMN F,SPSV ; THEN MUST DO THE INTSFX HACK
JRST IWLOOK
INTSFX: MOVE F,[PUSHJ FXP,SPWIN]
MOVSI R,-NSFC .SEE SFX
MOVEM F,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO
AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN TO SPWIN
HRRZ F,INTPDL ;RESTORE AC'S, AND SAVE
EXCH D,IPSD(F) ; INTERRUPT DESCRIPTOR
MOVE R,IPSR(F)
PUSH FXP,IPSPC(F) ;GET PC AND FLAGS
MOVEI F,IPSF(F)
PUSH FXP,F
MOVE F,(F)
JRST 2,@-1(FXP) ;CONTINUE WHATEVER WE WERE DOING
;;; RETURN FROM SFX HACK. ROUTINE HAS DONE PUSHJ FXP,SPWIN.
SPWIN: MOVEM F,@-1(FXP) ;PRESERVE F
HRRZ F,INTPDL
POP FXP,IPSPC(F) ;PUT PC BACK INTO INTPDL FRAME,
SOS IPSPC(F) ; BACKED UP TO THE CLOBBERED INSTRUCTION
SUB FXP,R70+2
MOVEM R,IPSR(F) ;SAVE ACS D AND R
EXCH D,IPSD(F)
MOVSI R,-NSFC
SPWIN1: MOVE F,SFXTBI(R) ;RESTORE THE LOCATIONS THAT WE
MOVEM F,@SFXTBL(R) ; CLOBBERED WITH PUSHJ FXP,SPWIN
AOBJN R,SPWIN1
JRST IWWIN ;WE HAVE WON
;IWLOOK INTXCT
IWLOOK: HRRZ F,INTPDL ;FAST BINARY SEARCH OF PROTECT
HRRZ R,IPSPC(F) ; TABLE ON PC INTERRUPTED FROM
PUSH FXP,D
MOVEI D,0
REPEAT LOG2NPRO,[
MOVE F,PROTB+<1←<LOG2NPRO-.RPCNT-1>>(D)
CAIL R,(F)
ADDI D,1←<LOG2NPRO-.RPCNT-1>
] ;END OF REPEAT LOG2NPRO
MOVS R,PROTB(D)
POP FXP,D
HRRZ F,INTPDL ;A USEFUL VALUE FOR F
JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL
;;; COME HERE TO MOVE THE PC FORWARD OUT OF A PROTECTED INTERVAL
;;; BY EXECUTING INTERVENING INSTRUCTIONS. THE ACS ARE CORRECTLY
;;; AVAILABLE DURING THIS EXECUTION, EXCEPT FXP. THE PC FLAGS ARE
;;; NOT PRESERVED. THUS, CODE IN SUCH A PROTECTED INTERVAL SHOULD
;;; NOT USE FXP OR THE PC FLAGS. NO JUMP INSTRUCTIONS MAY BE USED;
;;; HOWEVER, SKIPS ARE HANDLED CORRECTLY.
.SEE XCTPRO
INTXCT: PUSH FXP,IPSPC(F)
EXCH D,IPSD(F) ;RESTORE ACS D, R, AND F
MOVE R,IPSR(F) ;FLAGS ARE *NOT* RESTORED
MOVEI F,IPSF(F) ;ALSO, FXP IS OUT OF WHACK (BEWARE!)
PUSH FXP,F
MOVE F,(F)
XCT @-1(FXP) ;EXECUTE AN INSTRUCTION
CAIA
AOS -1(FXP) ;HANDLE SKIPS CORRECTLY
AOS -1(FXP)
MOVEM F,@(FXP)
SUB FXP,R70+1
HRRZ F,INTPDL
MOVEM R,IPSR(F)
EXCH D,IPSD(F)
POP FXP,IPSPC(F)
JRST IWLOOK ;MAY NEED TO XCT SOME MORE
;INTSYP INTSYQ INTSYX INTROT INTPPC INTC2X INTC2Y INTACT INTTYX INTACX INTZAX INTBAK INTBK1 INTOK IWWIN IWSTAK
INTSYP: SOS NPFFY2 .SEE SYCONS
INTSYQ: SOS NPFFY2
INTSYX: MOVEI R,PSYCONS
JRST INTBK1
INTROT: HLRZ R,R ;PROTECT CODE OF THE FORM
SUBI R,1 ; ROT A,-SEGLOG
ROT A,SEGLOG ; ... MUNCH ...
JRST INTBK1 ; ROT A,SEGLOG
INTPPC: HLRZ R,R ;PROTECT PURE CONSER
SUBI R,1 ;BACK UP TO THE AOSL OR WHATEVER
HRRM R,IPSPC(F)
SOS @(R) ;RESTORE THE COUNTER
JRST INTOK
INTC2X: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI R,CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTC2Y: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS
MOVEI R,%CONS1 ;HAIRY KIND OF BACKUP FOR CONS
JRST INTBK1
INTACT: HRRZ R,UUTSV .SEE UUOACL
JRST IWLOOK
INTTYX: HLRZ R,R ;ARRANGE TO GO TO INTTYR, WHICH WILL
PUSH P,R ; GET THE TTSAR BACK INTO T, THEN POPJ
MOVEI R,INTTYR .SEE TYOXCT TYIXCT TYICAL
HRRZS INHIBIT .SEE .5LKTOPOPJ
JRST INTBK1
INTACX: MOVSS A .SEE ACONS ;(RESTORES A FOR BACKUP)
MOVEI R,ACONS ;MAKE THIS THE NEW PC
JRST INTBK1
20$ INTSLP: ;FOR INTERRUPT FROM D20 SLEEP, MUST FLUSH "A"
INTZAX: SETZ A, ;CONSERS WHICH DON'T PROTECT THEIR FREELIST!
INTBAK: HLRZ R,R ;BACK UP PC TO BEGINNING
INTBK1: HRRM R,IPSPC(F) ; OF INTERVAL
INTOK: TLZ R,-1
HS$ 10$ CAIL R,400000 ;NO ARRAYS IN HIGH SEGMENT!
HS$ 10$ JRST IWWIN
CAML R,@VBPEND
JRST INTSFX
IWWIN: HRRZ F,INTPDL ;WE HAVE WON!
POPJ FXP,
;;; NEED WE PIOF AROUND THIS JSR UISTAK ?? E.G. WHAT ABOUT MEMERR?
IWSTAK: JSR UISTAK ;WE ARE IN A BAD STATE --
AOS (FXP) ; STACK UP THE INTERRUPT
JRST IWWIN
PGTOP INT,[INTERRUPT AND UUO HANDLERS]
;PATCH EPATCH NPURPG INUM PFXEST SYMEST LSYALC GSNSYSG GSNSY2 GSNPFXSG KNOB KNOB
SUBTTL STRUCT INSERT, BIT TABLES, AND SPACE CALCULATIONS
IFE LOPATCH,[
EXPUNGE PATCH PAT XPATCH
PATCH: PAT: XPATCH: BLOCK PTCSIZ
EPATCH==.-1
] ;END OF IFE LOPATCH
PAGEUP
PG% BSYSSG==HILOC-STDHI ;CROCK - BEWARE RELOCATION!
SPCTOP SYS,,[SYSTEM]
PG% EXPUNGE BSYSSG
NPURPG==<.-BPURPG>/PAGSIZ
10$ $LOSEG
INUM==.
;;@ STRUCT 405 INITIAL LIST STRUCTURE
;;; ***** MACLISP ****** INITIAL LIST STRUCTURE ******************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL MACROS FOR CREATING INITIAL LIST STRUCTURE
PFXEST==3200 ;ESTIMATED SPACE NEEDED FOR PURE FIXNUMS
SYMEST==1100 ;ESTIMATED INITIAL NUMBER OF LISP SYMBOLS
LSYALC==20
GSNSYSG==<SYMEST+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF SYM SEGS NEEDED
GSNSY2==<<SYMEST*2>+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF SY2 SEGS NEEDED
GSNPFXSG==<PFXEST+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF PFX SEGS NEEDED
MAYBE NXVCSG==PAGING*2000/SEGSIZ
.NSTGWD ;NO STORAGE WORDS OVER MACRO DEFINITIONS
KNOB==0 ;NUMBER OF OBJECTS FOR OBARRAY
.XCREF KNOB
DEFINE PUTOB A
REL$ ADDOB \A-.RL1,\KNOB
REL% ADDOB \A,\KNOB
TERMIN
DEFINE ADDOB A,N
DEFINE OB!N
REL$ .RL1+A
REL% A
TERMIN
KNOB==KNOB+1
TERMIN
;;; STANDARD FUNCTION MAKERS
;;; MKAT <PNAME/INTERNAL-NAME>,<PROP-NAME>,<SPACE-FOR-Q-LABEL>,<ARGS-PROP>
;;; MKAT1 <PNAME>,<PROP-NAME>,<SPACE-FOR-Q-LABEL>,<INTERNAL-NAME>,<ARGS-PROP>
DEFINE MKAT A,B,C,D
Q!B %
A,,NIL
RMTAH1 [C]A,PNL-2,[A]D,SUNBOUND,100
TERMIN
DEFINE MKAT1 A,B,C,D,E
Q!B %
D,,NIL
RMTAH1 [C]D,PNL-2,[A]E,SUNBOUND,100
TERMIN
;C.. C. PNL F.
;;; MKAT2 USED TO CREATE AUTOLOAD ATOMS
;;; MKAT2 <ATOM-NAME>,<BRIEF-NAME-FOR-AUTOLOAD-PROP>,<LABEL-FOR-HEADER>
DEFINE MKAT2 A,D,C
QAUTOLOAD %
QFL.!D,,NIL
IFSN [C], RMTAH1 [ ]C,PNL-2,[A],SUNBOUND,100
IFSE [C], RMTAH1 [ ]A,PNL-2,[A],SUNBOUND,100
TERMIN
;;; MAKE AN ATOM WITH AUTOLOAD PROPERTY FROM A SHARED PROPERTY LIST
;;; <PNAME>,<2-CHAR-PLIST-ID>,<BRIEF-INTERNAL-NAME>,<NO.-OF-ARGS>
DEFINE MKAL A,D,C,E
IFSN [C], RMTAH1 [ ]C,D!$AL,[A]E,SUNBOUND,100
IFSE [C], RMTAH1 ,,D!$AL,[A]E,SUNBOUND,100
TERMIN
;;; SAME AS MKAL, BUT WITH A VALUE CELL.
;;; "BRIEF" INTERNAL NAME MAY NOT BE OMITTED
DEFINE MKALV A,D,C,E,VAL
RMTAH1 [ ]C,D!$AL,[A]E,V!C,100
RMTVC V!C,VAL
TERMIN
;;; MAKES AN ATOM WITH A VALUE CELL, BUT NO OTHER PROPERTIES
;;; MKAV <PNAME>,<LABEL-FOR-VCELL>,<CONTENTS-OF-VCELL>,<LABEL-FOR-HEADER>
DEFINE MKAV PN,VCL,C,D
IFSN [D], RMTAH1 [ ]D,,[PN],C.,100
IFSE [D], RMTAH1 ,,,[PN],C.,100
C..==.
LOC C.
IFSN [VCL], VCL:
.ELSE, V!PN:
IFSN [C], C
.ELSE, NIL
C.==.
LOC C..
TERMIN
;;; MAKES A FUNCTION WITH A VALUE CELL
;;; MKFV <PNAME>,<INTERNAL-NAME>,<PROP-NAME>,<INITIAL-VALUE>,<ARGS-PROP>
DEFINE MKFV PN,B,C,D,E
Q!C %
B,,NIL
RMTAH1 [ ]B,PNL-2,[PN]E,V!B,100
RMTVC V!B,D
TERMIN
;;; STRINGS TOGETHER THE WORDS OF A PNAME INTO A LIST
DEFINE APN,PN
(F.)!REPEAT <<.LENGTH }PN}>+4>/5-1,[%
(F.+.RPCNT+1)]
PNL==.
LOC F.
ASCII }PN}
F.==.
LOC PNL
TERMIN
;PNL S. B. ZZ A C.
;;; MAKES A "SYSTEM" ATOM. USUSALLY HAS NO PROPERTIES.
;;; MSA <INTERNAL-NAME>,<PNAME>
DEFINE MSA LN,PN
RMTAH1 [ ]LN,,[PN],SUNBOUND,100
TERMIN
;;; MAKE A "RANDOM ATOM" (OR ATOMS)
DEFINE MRA PNS
IRP PN,,[PNS]
MSA PN,PN
TERMIN
TERMIN
;;; C = <SPACE> MEANS THAT WE SHOULD HAVE A LABEL FOR THE HEADER
;;; D IS THE LABEL, MORE OR LESS, IF C IS A <SPACE>
;;; PL IS FLAG FOR PROPERTY LIST. IF NULL, THEN NIL [= 0] GETS
;;; ASSEMBLED. FOR MKAT CASE, IT MUST BE "PNL-2", SINCE THE PROPERTY
;;; LIST WILL ALWAYS HAVE 2 CELLS JUST PRECEEDING THE PNAME-LIST
;;; PN IS THE PNAME STRING,
;;; AR THE ARGS PROPERTY,
;;; V THE LABEL OF THE VALUE CELL
;;; UC IS FOR THE "COMPILED-CODE-NEEDS-ME" BITS - 100 SAYS USED AS FUNCTION
;;; 40 SAYS USED IN STRUCTURES
DEFINE RMTAH1 C,D,PL,PN,AR,V,UC
PNL==.
LOC S.
PUTOB .
IFSE [C] , Q!D:
B.,,PL
S.==.
LOC B.
UC\777200,,V
NN!AR,,PNL
B.==.
LOC PNL
APN [PN]
TERMIN
;;; REMOTE VALUE CELL MAKER
DEFINE RMTVC A,C
ZZ==.
LOC C.
A:
IFSN [C], C
.ELSE, NIL
C.==.
LOC ZZ
TERMIN
;;; ARGS TO IRP IN GROUPS OF 4 FOR EASY COUNTING
IRP Q,,[0,,1,2
3,4,5,01
12,23,16,36
08,1777,2777,02
13,34,35,45
03,27,37,04
3777,17]R,,[1,0,2,3
4,5,6,1002
2003,3004,2007,4007
1011,2777,3777,1003
2004,4005,4006,5006
1004,3010,4010,1005
4777,2010]
NN!Q==R
TERMIN ;FOR BIBOP ARGS PROPERTIES
;BLSTIM DEDSAR DBM BSYSAR OBARRAY READTABLE PRDTBL TTYIFA TTYOFA INIIFA ESYSAR
SUBTTL STARTS FOR SAR, VC, IS2, AND SYM [SYMBOL-HEADER] SPACES
;;; STATE OF THE WORLD HERE HAD BETTER BE
;;; 1) LOSEG IF IN D10
;;; 2) BEGINNING ON A SEGMENT BOUNDARY
.XCREF RMTAH1 MKAT MKAT1 MKAT2 MKAV MKFV RMTVC MSA
.XCREF MKAL MKALV
.YSTGWD ;STORAGE WORDS ARE OKAY NOW
PGBOT ATM
BLSTIM==.MRUNT
;;; FORMAT OF SYMBOL HEADER FOR BIBOP:
;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE.
;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF
;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA.
;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST
;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF
;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE
;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO.
;;; THE SYMBOL BLOCK IS 2 WORDS LONG:
;;; <VARIOUS BITS>,,<POINTER TO VALUE CELL>
;;; <ARGS PROPERTY>,,<PNAME LIST>
;;; THE "VARIOUS BITS" ARE:
;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON)
;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK)
;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK)
;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL
;;; 3.6 ONE IFF COMPILED CODE REFERENCES BY OTHER THAN CALL UUO
;;; (IMPLIES 3.7 WHICH *MUST* ALSO BE ON)
;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE)
;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES,
;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS:
;;; 0 => NIL
;;; 777 => 777 (EFFECTIVELY INFINITY)
;;; N => N-1, N NOT 0 OR 777
;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777)
SPCBOT SAR
DEDSAR: 0,,ADEAD ;DEAD SAR (PROTECTED BY GC)
TTDEAD
DBM: 0,,ADEAD ;DEAD BLOCK MARKER
TTDEAD
BSYSAR==. ;BEGINNING OF "SYSTEM" ARRAY PROPS (SEE SYSP)
OBARRAY: AS<OBA+SX+GCP>,,IOBAR1 ;OBARRAY
TTS<1D+CN>,,IOBAR2(TT)
READTABLE: AS<RDT+FX>,,RSXTB1 ;READTABLE
TTS<1D+CN>,,RCT(TT)
PRDTBL: AS<RDT+FX>,,RSXTB2 ;PURE READTABLE
TTS<1D+CN>,,RCT0(TT)
TTYIFA: AS<FIL+SX+GCP>,,TTYIF1 ;TTY INPUT FILE ARRAY
TTS<1D+CL+CN+TY>,,TTYIF2(TT)
TTYOFA: AS<FIL+SX+GCP>,,TTYOF1 ;TTY OUTPUT FILE ARRAY
TTS<1D+CL+CN+TY+IO>,,TTYOF2(TT)
INIIFA: AS<FIL+SX+GCP>,,INIIF1 ;INIT FILE ARRAY
TTS<1D+CL>,,INIIF2(TT)
ESYSAR==.
SPCTOP SAR,ILS,[SAR]
;C. BXVCSG BXVCSG EVCSG SY2ALC SYMSYF TRUTH QUNBOUND SYALC S. ESYMGS
;;; BEGINS ON A SEGMENT BOUNDARY, BECAUSE OF THE "SPCTOP SAR"
SPCBOT VC
C.==. ;LOCATION COUNTER FOR VALUE CELL SPACE
;;; NOTE THAT VALUE CELLS FOR T, NIL, UNBOUND, AND UBAR
;;; ARE IN PURE FREE STORAGE
BLOCK 400
SEGUP .
BXVCSG==.
IFN NXVCSG,[
PAGEUP
BXVCSG==.
LOC .+NXVCSG*SEGSIZ-1
PAGEUP
]
EVCSG==.
SPCBOT IS2
SY2ALC:
LOC .+2*LSYALC
SPCTOP IS2,ILS,[IMPURE SYMBOL BLOCK]
SPCBOT SYM
SYMSYF:: ;FIRST LOC OF SYSTEM SYMBOLS
TRUTH: $$$TRUTH,,NIL ;ATOM HEADER FOR T
PUTOB TRUTH
REL$ ADDOB -.RL1+NIL,\KNOB
REL% ADDOB NIL,\KNOB
;;; CROCK TO PUTOB NIL CORRECTLY
QUNBOUND: $$$UNBOUND,,NIL ;INTERNAL UNBOUND MARKER
SYALC: BLOCK LSYALC ;FOR ALLOC
S.==. ;LOCATION COUNTER FOR SYMBOL SPACE
SEGUP BSYMSG+GSNSYSG*SEGSIZ-1
;END OF SYMBOL GUESS
ESYMGS==.
PAGEUP
;$$$TRUTH $$$UNBOUND B. INR70 IPPN1 IPPN2 F. EPFXGS BPURFS $$UNBOUND $$NIL VNIL $$TRUTH VT VTRUTH SUNBOUND SSSBRL ASBRL SYSBRL SBRL QGRTL
SUBTTL STARTS FOR SY2, PFX, AND PFS [PURE LIST] SPACES
10$ $HISEG
SPCBOT SY2
$$$TRUTH: 777300,,VTRUTH
0,,$$TRUTH
$$$UNBOUND: 777300,,SUNBOUND
0,,$$UNBOUND
B.==. ;LOCATION COUNTER FOR SYMBOL BLOCK SPACE
SEGUP BSY2SG+GSNSY2*SEGSIZ-1
SPCBOT PFX
INR70: R70
IFN TOPS10\CMU,[
IPPN1: . ;INITIAL PPN FOR LISP'S "SYS" DEVICE
IPPN2: .
] ;END OF IFN TOPS10\CMU
F.==. ;LOCATION COUNTER FOR PURE FIXNUMS - USED FOR PNAMES AND INUMS
SEGUP BPFXSG+GSNPFXSG*SEGSIZ-1
EPFXGS==.
SPCBOT PFS
BPURFS==. ;BEGINNING OF PURE FS (FOR INSERT FILE PAGE)
;;; FREE STORAGE STUFF THAT IS NEVER GC'ED, NOR DARE MARKED FROM (NON-BIBOP)
$$UNBOUND:
APN UNBOUND
$$NIL: ;PNAME FOR NIL
APN NIL
VNIL: NIL ;NIL'S VALUE CELL IS IN PFS - THAT WAY YOU CAN'T SETQ IT
$$TRUTH: ;PNAME OF T
APN T
VT:
VTRUTH: TRUTH ;LIKEWISE CAN'T SETQ T
;;; STANDARD UNBOUND VALUE CELL - POINTED TO BY ALL SYMBOLS WHICH
;;; DON'T HAVE THEIR OWN VALUE CELL. NOTE: ALL SUCH SYMBOLS ARE
;;; HELIOCENTRIC. MUST HAVE SUNBOUND ABOVE END OF VALUE CELL AREA
;;; - SEE GYSP5A AND SSYSTEM.
SUNBOUND: QUNBOUND
SSSBRL: QARRAY %
ASBRL: QAUTOLOAD %
SYSBRL: QARRAY,,SBRL
SBRL: QSUBR %
QFSUBR %
QLSUBR,,NIL
QGRTL: Q$GREAT,,NIL ;(>) FOR UGREAT
;RDQTEB PRMCLS BSYSAP QFL.ER ER$AL QFL.HE HE$AL QFL.AL AL$AL QFL.DA DA$AL QFL.NV NV$AL ESYSAP QA%DDD IRATBL IRACOM
SUBTTL +INTERNAL FUNCTIONS AND INITIAL AUTOLOAD PROPERTIES
RDQTEB=RDQTE ;THE OTHERS WIN BECAUSE THEY ARE 6 CHARS
IRP X,,[RDQTE,RDSEMI,RDVBAR]Y,,[['],[;],[|]]
MKAT1 [+INTERNAL-Y-MACRO]SUBR,[ ]X!B,0
TERMIN
MKAT1 +INTERNAL-TTYSCAN-SUBR,SUBR,[ ]TTYBUF,3
MKAT1 +INTERNAL-↑Q-MACRO,SUBR,[ ]CTRLQ,0
MKAT1 +INTERNAL-↑S-MACRO,SUBR,[ ]CTRLS,0
MKAT1 +INTERNAL-↑B-BREAK,SUBR,[ ]CN.BB,2
MKAT1 +INTERNAL-IOL-BREAK,SUBR,[ ]IOLB,1
MKAT1 +INTERNAL-UREAD-EOFFN,SUBR,[ ]UREOF,2
MKAT1 +INTERNAL-INCLUDE-EOFFN,SUBR,[ ]INCEOF,2
MKAT1 +INTERNAL-TTY-ENDPAGEFN,SUBR,[ ]TTYMOR,1
MKAT1 +INTERNAL-*RSET-BREAK,SUBR,[ ]CB,1
IRP X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC]
MKAT1 +INTERNAL-X-BREAK,SUBR,[ ]X!B,1
TERMIN
MKAT1 +INTERNAL-PDL-BREAK,SUBR,[ ]PDLB,1
MKAT1 +INTERNAL-GCO-BREAK,SUBR,[ ]GCOB,1
IFN NEWRD,[
;;;INITIAL ASSQ LIST OF MACRO-FUNCTIONS
PRMCLS: .+1,,.+2
47,,QRDQTE
.+1,,NIL
73,,QRDSEMI
] ;END OF IFN NEWRD
MKAT1 +INTERNAL-AUTOLOAD,SUBR,[ ]IALB
BSYSAP==. ;BEGINNING OF SYSTEM AUTOLOAD PROPERTIES
;;; NOTE THAT DUE TO THE 6-CHAR LOSS, GRINDEF HAD TO BECOME GFN IN THE LABEL
;;; HERE ARE THE NAMELISTS WHICH WILL BECOME AUTOLOAD PROPERTIES
IRPS A,,[GRIND,GFN,LAP,GETMI,SORT,LET,BACKQ,FORMA,CGOL
DEFMA,$DFMX,$EDIT,TRACE]B,C,[GI,GE,LA,GT,SO,LM,BQ,FT,CG,DF,DX,ED,TR]
QFL.!B: IRACOM %
Q!A,,IRATBL
B!$AL: QAUTOLOAD %
QFL.!B,,NIL
TERMIN
IFN SAIL,[
QFL.ER: IRACOM %
QEREAD,,IRATBL
ER$AL: QAUTOLOAD %
QFL.ER,,NIL
QFL.HE: IRACOM %
QHELP,,IRATBL
HE$AL: QAUTOLOAD %
QFL.HE,,NIL
]
IFN ITS,[
QFL.AL: IRACOM %
QALLFILES,,IRATBL
AL$AL: QAUTOLOAD %
QFL.AL,,NIL
] ;END OF IFN ITS
IFN USELESS,[
QFL.DA: IRACOM %
QDUMPARRAYS,,IRATBL
DA$AL: QAUTOLOAD %
QFL.DA,,NIL
] ;END OF IFN USELESS
IFN ITS*USELESS,[
QFL.NV: IRACOM %
QNVID,,IRATBL
NV$AL: QAUTOLOAD %
QFL.NV,,NIL
] ;END OF IFN ITS*USELESS
IFN JOBQIO,[
IRP A,,[LEDIT,LISPT,HUMBLE]B,,[LE,LT,HM]
QFL.!B: IRACOM %
Q!A,,IRATBL
B!$AL: QAUTOLOAD %
QFL.!B,,NIL
TERMIN
] ;END OF IFN JOBQIO
ESYSAP==. ;END OF SYSTEM AUTOLOAD PROPERTIES
QA%DDD: IRACOM,,NIL ;AUTOLOAD DEFAULT DEVICE/DIRECTORY LIST
IRATBL: QFASL,,NIL
IRACOM: ;STANDARD DEVICE/DIRECTORY FOR AUTOLOAD FILES
IFN ITS,[
QDSK % ;ON ITS, AUTOLOAD DEV/DIR IS DSK:LISP;
QLISP,,NIL
]
IFN D10,[
IFE SAIL,[
QLISP,,NIL ;ON TOPS-10, IT IS LISP:
] ;END OF IFE SAIL
IFN SAIL,[
QDSK % ;ON SAIL IT IS DSK:[MAC,LSP]
.+1,,NIL
QMAC %
QLSP,,NIL
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
QDSK % ;FOR D20 IT IS DSK:<MACLISP>
QMACLISP,,NIL
] ;END OF IFN D20
;BNM23A BNM23B BN.1A BNV2A QTLIST QLSPOUT QLSPOUT QUWL QURL LGOR
SUBTTL RANDOM LIST STRUCTURE
IFN BIGNUM,[
BNM23A: IN0 %
IN1,,NIL
BNM23B: IN0 %
IN2,,NIL
BN.1A: IN0+1,,NIL
BNV2A: BNV1,,NIL
] ;END OF IFN BIGNUM
QTLIST: TRUTH,,NIL
IFN ITS,[
QLSPOUT: Q.LISP. % ;FOR ITS, (/.LISP/. OUTPUT)
QOUTPUT,,NIL
] ;END OF IFN ITS
IFN D20,[
QLSPOUT: QMACLISP % ;FOR D20, (MACLISP OUTPUT)
QOUTPUT,,NIL
] ;END OF IFN D20
;QLSPOUT CONSTRUCTED AT RUN TIME FOR D10
QUWL: QUWRITE,,NIL
QURL: QUREAD,,NIL
LGOR: QGO %
QRETURN,,NIL
;QNILSETQ QTSETQ QXSETQ ARQLS $QMLST QSJCL SPCNAMES PURSPCNAMES PDLNAMES
QNILSETQ: QSETQ % ;FOR NIHIL ERROR MESSAGE
.+1,,NIL
NIL,,NIL
QTSETQ: QSETQ % ;FOR VERITAS ERROR MESSAGE
.+1,,NIL
TRUTH,,NIL
QXSETQ: QSETQ % ;FOR PURITAS ERROR MESSAGE
QXSET1,,NIL
ARQLS: QARRAY % ;(ARRAY ?)
$QMLST: QM,,NIL ;LIST OF A QUESTION MARK: (?)
QSJCL: QSTATUS % ;(STATUS JCL)
QJCL,,NIL
SPCNAMES: ;(STATUS SPCNAMES)
QSYMBOL %
QARRAY %
PURSPCNAMES: ;(STATUS PURSPCNAMES)
QLIST %
IFN HNKLOG,[
RADIX 10.
REPEAT HNKLOG+1, CONC QHUNK,\.RPCNT,,,.+1
RADIX 8
] ;END OF IFN HNKLOG
BG$ QBIGNUM %
DX$ QDUPLEX %
CX$ QCOMPLEX %
DB$ QDOUBLE %
QFLONUM %
QFIXNUM ,,NIL
PDLNAMES:
IRPS XX,Y,[REG FL FX SPEC]
Q!XX!PDL,,IFSE [Y][ ][.+1]
TERMIN
;QBIGNUM PLLISP
SUBTTL RANDOM SYSTEMIC ATOMS
;;; (LIST, FIXNUM, FLONUM, DOUBLE, COMPLEX, DUPLEX, BIGNUM,
;;; SYMBOL, <HUNKS>, RANDOM, ARRAY) MUST BE IN THAT ORDER
;;; (NOTE THAT THIS OVERLAPS THE NEXT LIST!)
COMMENT # QLIST: QFIXNUM: QFLONUM: QDOUBLE: QCOMPLEX: QDUPLEX:
QBIGNUM: QSYMBOL: QHUNK0: ... QHUNKn: QRANDOM: QARRAY: #
MKAT LIST,LSUBR,[ ]
MRA FIXNUM
MRA FLONUM
DB$ MRA DOUBLE
CX$ MRA COMPLEX
DX$ MRA DUPLEX
BG$ MRA BIGNUM
MRA SYMBOL
IFN HNKLOG,[
IRP X,,[0,1,2,3,4,5,6,7,8,9]SZ,,[2,4,8,16,32,64,128,256,512,1024]
MSA HUNK!X,HUNK!SZ
IFE .IRPCNT-HNKLOG, .ISTOP
TERMIN
] ;END OF IFN HNKLOG
MKAT RANDOM,LSUBR,[ ]01
;;; (ARRAY, SUBR, FSUBR, LSUBR, EXPR, FEXPR, MACRO, AUTOLOAD) MUST BE IN THAT ORDER
MKAT ARRAY,FSUBR,[ ]
MKAT SUBR,SUBR,[ ]1
IRP A,,[FSUBR,LSUBR,EXPR,FEXPR]
MRA A
TERMIN
MKAL MACRO,DF,MACRO
;;; (AUTOLOAD, ERRSET, *RSET-TRAP, GC-DAEMON,
;;; GC-OVERFLOW, PDL-OVERFLOW) MUST BE IN THAT ORDER
;;; NOTE THAT AUTOLOAD BELONGS TO SEQUENCE ABOVE ALSO
MKAV AUTOLOAD,VAUTFN,QIALB,AUTOLOAD
MKFV ERRSET,ERRSET,FSUBR
MKAV *RSET-TRAP,V.TRAP,QCB,.R.TP
MKAV GC-DAEMON,VGCDAEMON
MKAV GC-OVERFLOW,VGCO,QGCOB,GCO
MKAV PDL-OVERFLOW,VPDL,QPDLB,PDL
MRA [VALUE,LAMBDA,DSK,SYM,SPLICING,SINGLE,EVALARG,BPS]
IFE TOPS10\CMU, MRA LISP
IFN TOPS10\CMU,[
PLLISP: QPPN %
.+1,,NIL
IPPN1 %
IPPN2,,NIL
RMTAH1 [ ]LISP,PLLISP,LISP,,SUNBOUND,100
]
MRA [BIBOP,FASL,JCL,DDT,BACKQ]
IRP PN,,[OPTIONAL,REST,AUX]
MSA %!PN,&!PN
TERMIN
MSA %GLOBALSYM,GLOBALSYM
MRA [LABEL,FUNARG]
IT$ MRA COM
IT$ MRA COMMON
10$ MRA SYS
SA$ MRA [MAC,LSP]
10$ MRA PPN
;;; (REGPDL, FLPDL, FXPDL, SPECPDL) MUST BE IN THAT ORDER
MRA [REGPDL,FLPDL,FXPDL,SPECPDL]
;;; NEED COPIES OF DOUBLE, COMPLEX, DUPLEX, BIGNUM EVEN IF TYPES NOT IMPLEMENTED
.SEE LDATER
DB% MRA DOUBLE
CX% MRA COMPLEX
DX% MRA DUPLEX
BG% MRA BIGNUM
HN% MRA HUNK
IT$ MRA ITS
10$ MRA DEC10
20$ MRA DEC20
T10$ MSA TOPS10,TOPS-10
20$ MSA TOPS20,TOPS-20
10$ HS% MRA ONESEGMENT
PG$ MRA PAGING
20$ MRA TENEX
CMU$ MRA CMU
IT$ MRA EXPERIMENTAL
IFN USELESS, MRA ROMAN
MRA SAIL
IFN JOBQIO, MRA JOB
MRA [FILE,ECHO,CLA,IMAGE,BLOCK,NEWIO,OUTPUT,SCROLL]
MRA MACLISP
IT$ MRA [.LISP.,SLAVE]
MSA RDEOF,READ-EOF
MSA CN.B,[↑B]
MSA M,[?]
MSA ..MIS,[**MISSING-ARG**]
MSA LA,[←]
MSA XPRHSH,EXPR-HASH
;;; THESE FOUR MUST BE IN THIS ORDER!
.SEE UINT32
MKAT ODDP,SUBR,[ ]1
MKFV EVAL,OEVAL,LSUBR,NIL,12
MKAT DEPOSIT,SUBR,[ ]2
MKAT EXAMINE,SUBR,[ ]1
;
SUBTTL ATOMS FOR SUBRS
;DUMMY ATOM SO THAT BAKTRACE PRINTS SOMETHING REASONABLE IN CERTAIN SCREW CASES
MKAT1 QMARK,SUBR,,QMARK,0
MKAT GC,SUBR,,0
MKAT1 ↑G,SUBR,,CTRLG,0
;;; MUST HAVE (RUNTIME, TIME) IN THAT ORDER
MKAT1 RUNTIME,SUBR,[ ]$RUNTIME,0
MKAT1 TIME,SUBR,[ ]$TIME,0
MKFV CAR,CAR,SUBR,,1
MKFV CDR,CDR,SUBR,,1
IRPS A,C,[FIXP FLOATP RETURN EVALFRAME ERRFRAME,
BIGP,BOUNDP,LISTIFY
CAAR,CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,
CDDAR,CDDDR,CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,
CADDDR,CDAAAR,CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,
NOT,ATOM TYPEP,EXPLODE,MINUSP,PLUSP,NUMBERP ZEROP,
INTERN,LAST,REVERSE,NREVERSE,READLIST,MAKNAM,
LENGTH,ABS,MINUS,ADD1,SUB1,FIX,FLOAT,
FLATSIZE,FLATC,ARG COS,SQRT,LOG,EXP,
SXHASH,NOINTERRUPT,REMOB,SYSP,MAKUNBOUND,IMPLODE,MUNKAM
MAKNUM,SYMEVAL,PLIST,PURCOPY]
MKAT A,SUBR,[C]1
TERMIN
MKAT1 NCONS,SUBR,,$NCONS,1
MKAT1 SLEEP,SUBR,,$SLEEP,1
MKAT1 SIN,SUBR,,$SIN,1
IFN USELESS, MKAT HAULONG,SUBR,,1
IRPS A,C,[IFIX,EXPLODEC,NULL,ASCII ALLOC]
MKAT1 A,SUBR,[C]$!A,1
TERMIN
MKAT1 SYMBOLP,SUBR,,%SYMBOLP,1
MKAT1 EXPLODEN,SUBR,,$$EXPLODEN,1
MKAT1 ARRAYDIMS,SUBR,,ADIMS,1
MKAT1 PNGET,SUBR,,$PNGET,2
IRPS A,C,[SUBLIS REMPROP SET,RPLACA,RPLACD,NTH,NTHCDR,DISPLACE,
EQ,FRETURN,FRETRY,EXPT,MEMQ,SETARG MEMBER,EQUAL,GET,GETL,ASSOC,ASSQ,
REMAINDER,ATAN,SAMEPNAMEP,ALPHALESSP GETCHAR,COPYSYMBOL,PNPUT,
FILLARRAY NRECONC,SETPLIST]
MKAT A,SUBR,[C]2
TERMIN
MKAT1 XCONS,SUBR,,$XCONS,2
MKAT1 GETCHARN,SUBR,,$GETCHARN,2
IFN HNKLOG,[
MKAT CXR,SUBR,,2
MKFV MAKHUNK,MAKHUNK,SUBR,TRUTH,1
MKFV HUNKP,HUNKP,SUBR,TRUTH,1
MKAT HUNKSIZE,SUBR,,1
MKAT HUNK,LSUBR,[ ]
MKAT RPLACX,SUBR,,3
] ;END OF IFN HNKLOG
;
IFN USELESS,[
MKAT1 [\\]SUBR,,.GCD,2
IRPS A,C,[RECLAIM,HAIPART,GCD]
MKAT A,SUBR,[C]2
TERMIN
]
IRPS A,,[LSH,ROT,FSC]
MKAT1 A,SUBR,,$!A,2
TERMIN
MKAT1 ↑,SUBR,,XPTII,2
MKAT1 ↑$,SUBR,,XPTI$,2
MKAT1 *BREAK,SUBR,,$BREAK,2
MKAT1 *THROW,SUBR,,.THROW,2
IRPS A,,[DIF,QUO]
MKAT1 [*A]SUBR,,.!A,2
TERMIN
IRP A,,[1+,1-]B,,[ADD1,SUB1]
IRP C,,[$,]D,,[$,I]
MKAT1 [A!!C]SUBR,,[D!!B]1
TERMIN
TERMIN
IRP A,,[>,<]B,,[GREAT,LESS]
MKAT1 A,SUBR,[ ]$!B,2
TERMIN
MKAT1 =,SUBR,,$EQUAL,2
MKAT1 [\]SUBR,,REMAINDER,2
IRPS A,C,[SASSOC,SASSQ,SETSYNTAX,SUBST]
MKAT A,SUBR,[C]3
TERMIN
MKFV PUTPROP,PUTPROP,SUBR,SBRL,3
IFN ITS+D20, MKAT1 PURIFY,SUBR,,$PURIFY,3
IFN LHFLAG, MKAT1 LH|,SUBR,,LHVBAR,2
;
SUBTTL ATOMS FOR FSUBRS AND LSUBRS
IRPS A,C,[COND PROG QUOTE DO DECLARE PROGV,
DEFPROP CATCH THROW BREAK GO ,
SETQ ERR SIGNP STORE STATUS SSTATUS FUNCTION CASEQ ]
MKAT A,FSUBR,[C]
TERMIN
MKFV DEFUN,DEFUN,FSUBR,NIL
MKAT1 PUSH,FSUBR,[ ]$PUSH
MKAT1 POP,FSUBR,[ ]$POP
MKAT1 COMMENT,FSUBR,[ ]$COMMENT
MKAT1 UNWIND-PROTECT,FSUBR,[ ]UNWINP
MKAT1 *CATCH,FSUBR,[ ].CATCH
MKAT1 CATCHALL,FSUBR,,CATCHALL
MKAT1 CATCH-BARRIER,FSUBR,,CATCHB
MKAT1 AND,FSUBR,,$AND
MKAT1 OR,FSUBR,,$OR
MKAT1 EVAL-WHEN,FSUBR,[ ]EWHEN
MKAT1 *FUNCTION,FSUBR,[ ]%%FUNCTION
;;; MUST HAVE (MAPLIST,MAPCAR,MAP,MAPC,MAPCON,MAPCAN) IN THAT ORDER
MKAT MAPLIST,LSUBR,[ ]2777
MKAT MAPCAR,LSUBR,[ ]2777
MKAT1 MAP,LSUBR,[ ]$MAP,2777
MKAT MAPC,LSUBR,[ ]2777
MKAT MAPCON,LSUBR,[ ]2777
MKAT1 MAPCAN,LSUBR,[ ]$MAPCAN,2777
MKAT PROG2,LSUBR,[ ]2777
MKAT PROGN,LSUBR,[ ]
MKAT BOOLE,LSUBR,,2777
IRPS A,C,[DELQ DELETE APPLY ]
MKAT A,LSUBR,[C]23
TERMIN
IT$ MKAT SYSCALL,LSUBR,[ ]2777
MKAT1 LIST*,LSUBR,[ ]LIST.,1777
MKAT1 CONS,SUBR,,$C2NS,2
MKAT FUNCALL,LSUBR,[ ]1777
MKAT1 ARRAYCALL,FSUBR,[ ]%ARRAYCALL
MKAT SUBRCALL,FSUBR,[ ]
MKAT1 LSUBRCALL,FSUBR,[ ]%LSUBRCALL
IRPS A,C,[VALRET BAKTRACE BAKLIST GENSYM ]
MKAT A,LSUBR,[C]01
TERMIN
MKAT SUSPEND,LSUBR,[ ]02
IFN USELESS*ITS, MKAT CURSORPOS,LSUBR,[ ]03
MKAT QUIT,LSUBR,[ ]01
MKAT1 ERROR,LSUBR,[ ]$ERROR,03
MKAT GETSP,LSUBR,[ ]12
MKAT MAPATOMS,LSUBR,[ ]12
IRPS A,C,[NCONC PLUS,TIMES,DIFFERENCE,QUOTIENT,APPEND ]
MKAT A,LSUBR,[C]
TERMIN
;
;;; MUST HAVE (MAX,GREATERP,MIN,LESSP) IN THAT ORDER
MKAT MAX,LSUBR,[ ]1777
MKAT GREATERP,LSUBR,[ ]2777
MKAT MIN,LSUBR,[ ]1777
MKAT LESSP,LSUBR,[ ]2777
;;; IN THE FOLLOWING, NOTE THAT +, -, *, AND / GET VALUE CELLS
IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT]
MKFV [A]I!B,LSUBR,QI!B
TERMIN
IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT]
MKAT1 [A!$]LSUBR,,[$!B]
TERMIN
MKAT1 *REARRAY,LSUBR,[ ].REARRAY,17
MKAT1 *ARRAY,LSUBR,[ ]%%ARRAY,27
MKAT LISTARRAY,LSUBR,[ ]12
;
SUBTTL ATOMS FOR LAP, FASLAP, AND FASLOAD USAGE
;;; SUBROUTINES USED BY COMPILER OUTPUT - ERGO, NEEDED BY LAP
;;; AND FASLOAD. ALSO OTHER GOODIES FOR LAP AND FASLAP.
IRP A,,[DELQ,DELETE,APPEND,TIMES,GREAT,LESS,PLUS,NCONC,APPLY]
MKAT1 *A,SUBR,[ ].!A,2
TERMIN
IRP A,,[PRINT,PRIN1,PRINC,TERPRI,TYO]B,,[PRT,PR1,PRC,TRP,TYO]C,,[1,1,1,0,1]
MKAT1 *!A,SUBR,[ ]B!$,C
TERMIN
IRP A,,[READ,READCH,TYI]B,,[READ,RDCH,TYI]C,,[0,0,0]
MKAT1 *!A,SUBR,[ ]B!$,C
TERMIN
MKAT1 *EVAL,SUBR,,EVAL,1
MKAV PURE,VPURE,IN1*PAGING ;INIT TO NIL OR 1 (IF PAGING SYS)
MKAV *PURE,V.PURE
MKAV PURCLOBRL
MKAT1 FASLAPSETUP|,SUBR,,FSLSTP,1
MKFV LAPSETUP|,LAPSETUP,SUBR,,2
MKAT PAGEBPORG,SUBR,[ ]0
MKFV TTSR|,TTSR,SUBR
MKAT1 SQOZ|,SUBR,,5BTWD,1
MKAT GETDDTSYM,SUBR,[ ]1
MKAT PUTDDTSYM,SUBR,,2
MKFV GCPROTECT,GCPRO,SUBR,,2
MKAV SYMBOLS,V$SYMBOLS,,$SYMBOLS
MKFV FASLOAD,FASLOAD,FSUBR,SBRL
;
;
SUBTTL ATOMS FOR AUTOLOAD FEATURES
IFN JOBQIO,[
MKAL LEDIT,LE,LEDIT
MKAL LISPT,LT,LISPT
MKAL [INF-EDIT]LT
] ;END OF IFN JOBQIO
IT$ MKAL HUMBLE,HM,HUMBLE
IT$ MKAL [CREATE-JOB]HM
IRPS A,C,[GRIND,LAP,LET,TRACE,FORMAT,CGOL]B,,[GI,LA,LM,TR,FT,CG]
MKAL A,B,A
TERMIN
IRP A,,[GRIND0,CGOLREAD,DESETQ]B,,[GI,CG,LM]
MKAL A,B
TERMIN
MKAL SPRINTER,GE,,1
MKAL GETMIDASOP,GT,GETMIDASOP,1
MKAL SORT,SO,SORT,2
MKAL SORTCAR,SO,,2
MKALV EDIT,ED,$EDIT
MKALV GRINDEF,GE,GFN
MKAL READMACROINVERSE,GE,$RMI
MKAL [+INTERNAL-`-grindmacros|]GE,,0
MKAL [LAP-A-LIST]LA
MKAL LET*,LM
SA$ MKAT2 EREAD,ER
SA$ MKAT2 HELP,HE
IFN USELESS,[
MKAL DUMPARRAYS,DA,DUMPARRAYS
MKAL LOADARRAYS,DA
] ;END OF IFN USELESS
IFN ITS,[
MKAL ALLFILES,AL,ALLFILES
IRP A,,[MAPALLFILES,DIRECTORY,MAPDIRECTORY]
MKAL A,AL
TERMIN
] ;END OF IFN ITS
IFN ITS*USELESS,[
MKAL NVID,NV,NVID
MKAL SFTV|,NV,SFTV.
] ;END IFN ITS*USELESS
MKAV BACKQUOTE-EXPAND-WHEN,V%BEW,QOEVAL
MKAV [`-,-level|]V%BCLV,IN0
MKAL [`-expander|]BQ
MKAL [`-expander| MACRO]BQ
MKAL [`,|]BQ
MKAL [`,@|]BQ
MKAL [`,.|]BQ
MKAL [+ibx|]BQ,,1
MKAL [+INTERNAL-macro-loser|]BQ,,1
MKAL [+INTERNAL-`-macro|]BQ,I%B%F,0
MKAL [+INTERNAL-,-macro|]BQ,I%C%F,0
MSA $DFMX,DEFMAX
MKAV DEFMACRO-CHECK-ARGS,V%DCA,TRUTH
MKAV DEFMACRO-DISPLACE-CALL,V%DDC,TRUTH
MKAV DEFMACRO-FOR-COMPILING,V%DFC,TRUTH
MKAV MACRO-EXPANSION-USE,V%MEU,Q%MXPD
MKAV GRIND-MACROEXPANDED,V%GMX
MKAL [MACROEXPANDED-grindmacro|]DX,,0
MKAL MACROFETCH,DX,,1
MKALV MACROMEMO,DX,%MCMO,3
MKAL MACROEXPAND,DX,,1
MKAL MACROEXPAND-1,DX,,1
MKAL [forget-macromemos|]DX,,1
MKALV MACROEXPANDED,DX,%MXPD
MKAL [MACROEXPANDED MACRO]DX,,1
MKAL [DEFUN&]DF,%DEFUN
MKAL [DEFUN& MACRO]DF,,1
;;; MKAL MACRO,DF,MACRO ;;; NOTE THAT THIS MUST BE "ABOVE"
MKAL [MACRO MACRO]DF,,1
MKAL DEFMACRO,DF,DEFMA
MKAL [DEFMACRO MACRO]DF,,1
MKAL DEFMACRO-DISPLACE,DF
MKAL [DEFMACRO-DISPLACE MACRO]DF,,1
MKAL [MACRO-macroexpander|]DF
MKAL [MACRO-macroexpander| MACRO]DF,,1
MKALV [DEFUN&-ERROR]DF,DF$ER,0
;
SUBTTL ATOMS FOR ODDBALL FUNCTIONS AND VARIABLES
IFN ITS, MKFV ALARMCLOCK,ALARMCLOCK,SUBR,,2
IFE ITS, VALARM==VNIL
IFN USELESS,[ ;THESE MUST BE IN THIS ORDER, FOLLOWNG ALARMCLOCK
MKAV CLI-MESSAGE,VCLI,,CLI
MKAV MAR-BREAK,VMAR,,MAR
MKAV TTY-RETURN,VTTR,,TTR
MKAV SYS-DEATH,VSYSD,,SYSD
] ;END OF IFN USELESS
MKFV NOUUO,NOUUO,SUBR,,1
MKFV NORET,NORET,SUBR,,1
MKFV EVALHOOK,EVALHOOK,LSUBR,,23
MKFV READ-EVAL-*-PRINT,TLPRINT,SUBR,,1
MKFV READ-EVAL-PRINT-*,TLTERPRI,SUBR,,0
MKFV *-READ-EVAL-PRINT,TLREAD,SUBR,,0
MKFV READ-*-EVAL-PRINT,TLEVAL,SUBR,,1
MKFV GCTWA,GCTWA,FSUBR
MKFV ARGS,ARGS,LSUBR,,12
MKFV *RSET,.RSET,SUBR,TRUTH,1
MKFV *NOPOINT,.NOPOINT,SUBR,,1
MKFV OBARRAY,OBARRAY,ARRAY,OBARRAY
MKFV READTABLE,READTABLE,ARRAY,READTABLE
;
SUBTTL ATOMS FOR NEWIO FUNCTIONS AND VARIABLES
IRPS A,C,[NAMELIST,NAMESTRING,SHORTNAMESTRING,TRUENAME INPUSH,PROBEF,LOAD FILEP]
MKAT A,SUBR,[C]1
TERMIN
MKFV DEFAULTF,DEFAULTF,SUBR,,1
MRA NODEFAULT
MKAT1 FORCE-OUTPUT,SUBR,[ ]FORCE,1
MKAT1 CLEAR-OUTPUT,SUBR,,CLROUT,1
MKAT1 CLEAR-INPUT,SUBR,,CLRIN,1
IRPS A,C,[CLOSE DELETEF IN FASLP ]
MKAT1 A,SUBR,[C]$!A,1
TERMIN
MKAT1 +TYO,SUBR,,PTYO,2
MKAT1 OPEN,LSUBR,[ ]$OPEN,02
SA$ MKAT1 EOPEN,LSUBR,[ ]$EOPEN,04
MKAT1 OUT,SUBR,[ ]$OUT,2
MKAT1 RENAMEF,SUBR,[ ]$RENAMEF,2
MKAT CNAMEF,SUBR,[ ]2
MKAT MERGEF,SUBR,,2
MKAT1 LENGTHF,SUBR,[ ]$LENGTHF,1
MKAT1 LISTEN,LSUBR,[ ]$LISTEN,01
IFN SFA,[
MKAT1 SFA-CREATE,SUBR,,STCREA,3
MKAT1 SFA-CALL,SUBR,,STCALL,3
MKAT1 SFAP,SUBR,,STPRED,1
MKAT1 SFA-GET,SUBR,,STGET,2
MKAT1 SFA-STORE,SUBR,,STSTOR,3
MSA WOP,WHICH-OPERATIONS
MRA FILEMODE
MRA UNTYI
MRA SFA
MRA PNAME
MRA NAME
MRA PROBEF
MRA TTYSCAN
MRA TTYCONS
] ;END IFN SFA
IRPS A,C,[CRUNIT,UKILL,UFILE UCLOSE,UAPPEND,UPROBE,INCLUDE]
MKAT A,FSUBR,[C]
TERMIN
MKFV UREAD,UREAD,FSUBR
MKFV UWRITE,UWRITE,FSUBR
IRPS A,,[INFILE,INSTACK,OUTFILES,ECHOFILES]C,,[TRUTH,,,]
MKAV A,,C
TERMIN
MKAV MSGFILES,,QTLIST,MSGFILES
MKFV TYI,%TYI,LSUBR,TTYIFA,02
MKAT1 READLINE,LSUBR,[ ]%READLINE,02
MKAT TYIPEEK,LSUBR,[ ]03
MKFV TYO,%TYO,LSUBR,TTYOFA,12
MKAT1 PRINT,LSUBR,[ ]%PRINT,12
MKFV PRIN1,%PR1,LSUBR,,12
MKAT1 PRINC,LSUBR,[ ]%PRC,12
MKFV TERPRI,%TERPRI,LSUBR,,01
MKFV READ,OREAD,LSUBR,,02
MKAT1 READCH,LSUBR,[ ]$READCH,02
IRPS A,C,[ENDPAGEFN EOFFN PAGEL CHARPOS LINENUM PAGENUM LINEL RUBOUT FILEPOS ERRPRINT ]
MKAT A,LSUBR,[C]12
TERMIN
;DOLLRP
SUBTTL ATOMS FOR VARIABLES AND USER INTERRUPT BREAKS
;;; TTYOPN WILL INIT VLINEL TO THE RIGHT THINGS.
;;; FOR NON-BIBOP, NOTE THAT LINEL AND CHRCT POINT INTO THE
;;; (UNRELOCATED!) INUM AREA DURING ALLOC. THEY WILL THUS
;;; HAVE THE RIGHT VALUES BUT THE WRONG TYPE (I.E. TYPEP
;;; OF THEM WOULD LOSE.) THUS PRINT ETC. SHOULD NOT CHECK
;;; TYPEP OF THESE THINGS. ALLOC REHACKS THEIR VALUES AFTERWARDS.
;;; CHRCT IS INITIALLY 777 SO ALLOC WON'T GENERATE CR'S.
COMMENT | VBPORG: VBPEND: VERRLIST: VTTY: VZUNDERFLOW: VZFUZZ: VCHRCT: VLINEL: |
IRP A,,[BPEND,BPORG,ERRLIST,TTY,ZUNDERFLOW]C,,[VBPE1,VBP1,,,]
MKAV A,,C,A
TERMIN
BG$ MKAV ZFUZZ,,,ZFUZZ
COMMENT | VIBASE: VBASE: V%LEVEL: V%LENGTH: TAPRED: TTYOFF: TAPWRT: SIGNAL: |
;;; FOR NON-BIBOP, ALLOC REHACKS VBASE AND VIBASE AFTERWARDS.
MKAV IBASE,,IN10,IBASE
MKAV BASE,,IN10,BASE
IFN USELESS,[
MKAV PRINLEVEL,V%LEVEL,,%LEVEL
MKAV PRINLENGTH,V%LENGTH,,%LENGTH
] ;END OF IFN USELESS
IRP A,,[↑Q,↑W,↑R,↑A]B,,[TAPRED,TTYOFF,TAPWRT,SIGNAL]
MKAV A,B
TERMIN
SA% MKAV [≠P]VDOLLRP,QDOLLRP,DOLLRP
SA$ MKAV [}P]VDOLLRP,QDOLLRP,DOLLRP
DOLLRP==QDOLLRP
MKAV ↑D,GCGAGV,,CN.D
;;; (UNDF-FNCTN, UNBND-VRBL, WRNG-TYPE-ARG,
;;; UNSEEN-GO-TAG, WRNG-NO-ARGS, GC-LOSSAGE, FAIL-ACT,
;;; IO-LOSSAGE) MUST BE IN THAT ORDER
IRP A,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC]PN,,[UNDF-FNCTN,UNBND-VRBL
WRNG-TYPE-ARG,UNSEEN-GO-TAG,WRNG-NO-ARGS,GC-LOSSAGE,FAIL-ACT]
MKAV PN,V!A,Q!A!B,A
TERMIN
MKAV IO-LOSSAGE,VIOL,QIOLB,IOL
MKAV COMPILER-STATE,VCOMST
MKAV MACHINE-ERROR,VMERR,,MERR
PGTOP ATM,[SYSTEM ATOMS AND STUFF]
;PFSLAST ESYSVC LISAR TYIMAN UNTYIMAN UNREADMAN READPMAN FASLP TIRPATE ARGLOC ARGNUM
;;; ************* END OF PURE LISP (NON-BIBOP) *************
PFSLAST==. ;GUARANTEED SAFE OVER SPCTOP
10$ $LOSEG
LOC C.
ESYSVC==.
EXPUNGE C.
SUBTTL RANDOM BINDABLE CELLS
;;; HERE ARE THINGS WHICH ARE LIKE VALUE CELLS, IN THAT SPECPDL
;;; UNBINDING MUST WORK ON THEM; BUT THEY ARE NOT NECESSARILY
;;; MARKED FROM.
LISAR: NIL ;LAST INTERPRETIVELY-SEEN ARRAY - ASAR
TYIMAN: $DEVICE ;WHERE TO GET CHARACTERS FROM
UNTYIMAN: UNTYI ;WHERE TO PUT BACK CHARACTERS TO
UNREADMAN: .+1
.VALUE
READPMAN: .+1
.VALUE
FASLP: NIL ;FASLOADING-P?
TIRPATE: 0 ;PSEUDO VALUE CELL, USED TO EXTIRPATE THE CONSEQUENT UNBINDING
;FOLLOWING A SETQ DONE ON NIL OR T
;;; #### MOOOBY IMPORTANT! MUST HAVE <ADDRESS OF ARGNUM> = <ADDRESS OF ARGLOC> + 1
ARGLOC: 0 ;FOR LEXPRS - LOCATION OF ARG VECTOR ON PDL
ARGNUM: 0 ;HOLDS FIXNUM WHICH IS # OF ARGS FOR LEXPR IN ARGLOC
;BFVCS INFVCS SYMSYL NXXASG NXXZSG BXXASG NXXASG BXXZSG NXXZSG NSY2SG ZZ ZZZ XHINUM XLONUM IN0
SUBTTL BIBOP STORAGE PARAMETER CALCULATIONS
BFVCS:
INFVCS==BXVCSG-BFVCS
IFL INFVCS, WARN \-INFVCS,[=TOO MANY VALUE CELLS]
SPCTOP VC,ILS,[VALUE CELL]
LOC S.
EXPUNGE S. B.
IFL ESYMGS-1-., WARN \.-ESYMGS,[=TOO MANY SYMBOLS (SYMEST=]\SYMEST,[)]
SYMSYL==:. ;ADR OF LAST SYSTEM SYM
SPCTOP SYM,ILS,[SYMBOL HEADER]
IFE PAGING,[
NXXASG==0
NXXZSG==0
$HISEG
] ;END OF IFE PAGING
IFN PAGING,[
BXXASG==.
NXXASG==<<<BXXASG+PAGSIZ-1>&PAGMSK>-BXXASG>/SEGSIZ
BXXZSG==BXXASG+NXXASG*SEGSIZ ;TAKE UP SLACK PAGES BEFORE SY2
NXXZSG==<BSY2SG-BXXZSG>/SEGSIZ
] ;END OF IFN PAGING
NSY2SG==<BPFXSG-BSY2SG>/SEGSIZ
SEGUP BSY2SG+NSY2SG*SEGSIZ-1
SPCTOP SY2,ILS,[PURE SYMBOL BLOCK]
LOC F.
EXPUNGE F.
IFL EPFXGS-1-HINUM-LONUM-., WARN \.+HINUM+LONUM-EPFXGS,[=TOO MANY PURE FIXNUMS (PFXEST=]\PFXEST,[)]
ZZ==EPFXGS-.
ZZZ==<ZZ-HINUM-LONUM>/2 ; THEN TO THE NEXT PAGE BOUNDARY
XHINUM==HINUM+ZZZ ;DISTRIBUTE ANY SUCH EXTRA SPACE EVENLY
IFL XHINUM-777,XHINUM==777 ;MANY LOSERS DEPEND ON HINUM BEING AT LEAST THIS BIG
XLONUM==ZZ-XHINUM ; BETWEEN POSITIVE AND NEGATIVE INUMS
IFL XLONUM-10,[
WARN [XLONUM=]\XLONUM,[, YOU WILL CERTAINLY LOSE]
.ERR INUM LOSSAGE
]
REPEAT XLONUM, .RPCNT-XLONUM
IN0: ;HAIRY PAGE (APPROXIMATELY) OF SMALL FIXNUMS
REPEAT XHINUM, .RPCNT
IRP X,,[1,2,3,4,5,6,7,10,777]
IN!X=IN0+X
TERMIN
INFORM [HIGHEST NLISP INUM=]\XHINUM
INFORM [LOWEST NLISP INUM=-]\XLONUM
SPCTOP PFX,ILS,[PURE FIXNUM]
LOC PFSLAST
SPCTOP PFS,ILS,[PURE LIST]
SPCBOT PFL
;;; INITIAL ASSEMBLED PURE FLONUMS GO HERE (HA HA!)
SPCTOP PFL,ILS,[PURE FLONUM]
10$ $LOSEG
;BXXPSG NXXPSG NPURFS FIRSTW QXSET1 NUNMRK FEATLS
SUBTTL INITIAL RANDOM IMPURE FREE STORAGE
IFN PAGING,[
BXXPSG==. ;POSSIBLE SLACK PURE SEGMENT
PAGEUP
NXXPSG==<.-BXXPSG>/SEGSIZ
SPCBOT IFS
NPURFS==<.-BPURFS>/PAGSIZ
] ;END OF IFN PAGING
.ELSE, SPCBOT IFS
FIRSTW:
QXSET1: .,,NIL ;FOR XSETQ
NUNMRK==.-FIRSTW .SEE GCP6
IFG NUNMRK-40, WARN \NUNMRK,[=TOO MANY UNMARKABLE FS LOCATIONS]
IT$ FEATEX: QEXPERIMENTAL %
FEATLS: ;INITIAL LIST FOR (STATUS FEATURES)
QBIBOP %
IFN BIGNUM, QBIGNUM %
QFASLOAD %
IFN HNKLOG, QHUNK %
QFUNARG %
IFN USELESS, QROMAN %
QNEWIO %
IFN SFA, QSFA %
10$ HS% QONESEGMENT %
PG$ QPAGING %
QMACLISP %
;PENULTIMATE IS DEC10/DEC20, OR ITS MACHINE NAME
IT$ MACHFT: NIL % ;STARTUP PUTS MACHINE NAME HERE
10$ QDEC10 %
20$ QDEC20 %
;OPERATING SYSTEM COMES LAST
IT$ QITS,,NIL
SA$ QSAIL,,NIL
T10$ QTOPS10,,NIL
CMU$ QCMU,,NIL
;STARTUP PUTS OS NAME HERE FOR ALL TWENEX/TENEX TYPE SYSTEMS
20$ OPSYFT: NIL,,NIL
;BPROTECT TLF BLF QF1SB PA3 GCPSAR RDLARG SUDIR FEATURES LDFNAM LDEVPRO NILPROPS DEOFFN DENDPAGEFN LPROTECT
;;; FROM BPROTECT, FOR DISTANCE LPROTECT, IS PROTECTED BY THE GARBAGE COLLECTOR.
.SEE GCP6Q2
BPROTECT:
BG$ BNV1,,ARGNUM ;TO PROTECT CONTENTS OF THESE CELLS
BG% NIL,,ARGNUM
TLF: NIL ;TOP LEVEL FORM - NIL FOR STANDARD
BLF: NIL ;ANALOGOUSLY, THE BREAK LEVEL FORM
QF1SB: NIL ;SAVE B DURING QF1
PA3: 0 ;RH = PROG BODY (I.E. CDDR OF PROG FORM)
;LH = NEXT PROG STATEMENT
GCPSAR: 0 ;POINTS TO SAR FOR HASH ARRAY FOR GC-PROTECTION LISTS
RDLARG: NIL ;LIST OF CHARS FOR READLIST, MAKNAM, IMPLODE
SUDIR: NIL ;INITIAL SNAME (ITS) OR PPN (DEC-10)
FEATURES: FEATLS
LDFNAM: NIL ;FASLOAD FILE NAME
LDEVPRO: NIL ;LIST OF EVALED-FROBS-IN-ATOMTABLE TO BE PROTECTED
NILPROPS: NIL ;PROPERTY LIST FOR NIL
DEOFFN: NIL ;DEFAULT EOF FUNCTION
DENDPAGEFN: NIL ;DEFAULT END OF PAGE FUNCTION
LPROTECT==:.-BPROTECT
;Q. V. IGCMKL OBTFS LFSALC FSALC VBP1 VBPE1 IGCFX1 IGCFX2 LFWSALC FWSALC NIFWAL
Q.=:QITIMES ;ALIASES FOR THE SYMBOL *
V.=:VITIMES
.HKILL QITIMES VITIMES
IGCMKL: DEDSAR % ;DEAD AREA AT TOP OF BPS
IGCFX1 %
INIIFA % ;INIT FILE ARRAY
IGCFX2,,NIL
OBTFS: BLOCK KNOB+10 ;FREE STORAGE FOR OBARRAY CONSAGE
LFSALC==100
FSALC: BLOCK LFSALC ;FOR ALLOC
SPCTOP IFS,ILS,[IMPURE LIST]
SPCBOT IFX
BG$ BNV1: . ;TEMPORARILY RPLACED BY BNCVTM
VBP1: BBPSSG ;INITIAL ALLOCATED VALUE FOR BPORG
VBPE1: INIIF1-2 ;INITIAL ALLOCATED VALUE FOR BPEND
IGCFX1:
PG$ <<ENDLISP+PAGSIZ-1>&PAGMSK>-EINIFA ;SIZE OF DEAD BLOCK
PG% 0 ;WILL BE CALCULATED BY ALLOC
IGCFX2: LINIFA ;SIZE OF INIT FILE ARRAY
LFWSALC==40
FWSALC: BLOCK LFWSALC ;FOR ALLOC
NIFWAL==0
SPCTOP IFX,ILS,[IMPURE FIXNUM]
;BBIGPRO BN235 BNM235 BNM236 BNV2 BN.1 LBIGPRO BBNSG NBNSG BXXBSG NXXBSG BLSTIM NBITB ZZ BTBLKS BFBTBS NBPSSG NFXPSG NFLPSG NPSG NSPSG NXFXPSG NXFLPSG NXPSG NXSPSG NNXMSG NNXMSG ZZX ZZX SPDLORG PDLORG FLPORG FXPORG ZZX ZZX SPDLORG PDLORG FLPORG FXPORG
SPCBOT IFL
1.0 ;NEED AT LEAST ONE IMPURE FLONUM SEGMENT
SPCTOP IFL,ILS,[IMPURE FLONUM]
IFN BIGNUM,[
SPCBOT BN
BBIGPRO: .SEE GCP6Q3 ;PROTECTED BIGNUMS
BN235: 0,,BNM23A
BNM235: -1,,BNM23A
BNM236: -1,,BNM23B
BNV2: 0,,BNV2A
BN.1: 0,,BN.1A
LBIGPRO==.-BBIGPRO
SPCTOP BN,ILS,[BIGNUM]
] ;END OF IFN BIGNUM
IFE BIGNUM,[
BBNSG==.
NBNSG==0
] ;END OF IFE BIGNUM
IFN PAGING,[
BXXBSG==. ;TAKE UP SLACK UNTIL FIRST PAGE OF BPS
PAGEUP
NXXBSG==<.-BXXBSG>/SEGSIZ
] ;END OF IFN PAGING
IF2 GEXPUN
BLSTIM==.MRUNT-BLSTIM
INFORM [TIME TO MAKE INITIAL STRUCT, PASS ]\.PASS,[ = ]\BLSTIM/1000.,[ SECS]
;;@ END OF STRUCT 405
;;; 10$ NOW IN ** LOW SEGMENT **
NBITB==NIFSSG+NIFXSG+NIFLSG+NBNSG
ZZ==<<NBITB+1>*BTBSIZ+SEGSIZ-1>/SEGSIZ
IFN ZZ-BTSGGS,[
WARN [NEEDED NUMBER OF INITIAL BIT TABLE SEGMENTS (]\ZZ,[) DOESN'T
MATCH GUESS. (BTSGGS=]\BTSGGS,[)
]
] ;END OF IFN ZZ-BTSGGS
.ALSO .ERR
IFN LOBITSG, BFBTBS=BTBLKS+NBITB*BTBSIZ
.ELSE,[ ;;; NOTE WELL! FIRST FS SEGMENT GETS FIRST
;;; BIT BLOCK! (SEE NUNMRK, GCP6)
SPCBOT BIT
BTBLKS: -1 ;THIS WILL BE RESET BY GCINBT
BLOCK NBITB*BTBSIZ-1
BFBTBS: ;BEGINNING OF FREE BIT BLOCKS
PAGEUP
SPCTOP BIT,ST,[BIT BLOCK]
] ;END OF .ELSE
NBPSSG==1*SGS%PG ;INIT WILL MUNG ST AND PURTBL ANYWAY TO PRESERVE ALLOC
NFXPSG==1*SGS%PG ;PDL AREAS FOR INIT AND ALLOC
NFLPSG==1*SGS%PG
NPSG==1*SGS%PG
NSPSG==1*SGS%PG ;ALLOC ALTERS ALL PDL PARAMETERS!!!
IFN PAGING,[
NXFXPSG==1*SGS%PG
NXFLPSG==1*SGS%PG
NXPSG==1*SGS%PG
NXSPSG==1*SGS%PG
IFE SFA,[
IFN ML, NSCRSG==2*SGS%PG
.ELSE NSCRSG==3*SGS%PG ;ALLOW FOR PDP6 PAGE (P6)
] ;END IFE SFA
IFN SFA,[
IFN ML, NSCRSG==1*SGS%PG
.ELSE NSCRSG==2*SGS%PG ;ALLOW FOR PDP6 PAGE (P6)
] ;END IFN SFA
;;; NUMBER OF NON-EXISTENT MEMORY SEGMENTS
;;; (TAKE ALL OF CORE AND SUBTRACT OUT EVERYTHING USEFUL!!!)
NNXMSG==NSEGS
IRP SPC,,[ZER,ST,SYS,SAR,VC,XVC,IS2,SYM,XXA,XXZ,SY2,PFX,PFS,PFL,XXP
IFS,IFX,IFL,BN,XXB,BIT,BPS,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
NNXMSG==NNXMSG-N!SPC!SG
TERMIN
;;; DETERMINE ORIGINS FOR ALL SPACES ABOVE THIS POINT
ZZX==.
IRP SPC,,[BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==MEMORY-<NSCRSG+NSPSG+NXSPSG>*SEGSIZ
PDLORG==SPDLORG-<NPSG+NXPSG>*SEGSIZ
FLPORG==PDLORG-<NFLPSG+NXFLPSG>*SEGSIZ
FXPORG==FLPORG-<NFXPSG+NXFXPSG>*SEGSIZ
] ;END OF IFN PAGING
IFE PAGING,[
ZZX==.
IRP SPC,,[FXP,FLP,P,SP,BPS]
B!SPC!SG==ZZX
ZZX==ZZX+N!SPC!SG*SEGSIZ
TERMIN
SPDLORG==BSPSG
PDLORG==BPSG
FLPORG==BFLPSG
FXPORG==BFXPSG
] ;END OF IFE PAGING
;OBTL INITIALIZE
SUBTTL APOCALYPSE (END OF THE WORLD)
;FOR REL ASSEMBLIES, INIT AND ALLOC CODE OVERLAP INITIAL BPS
10$ LOC BBPSSG
;;@ ALLOC 220 INITIALIZATION AND ALLOCATION ROUTINES
;;; ***** MACLISP ****** INITIALIZATION AND ALLOCATION ROUTINES **
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
CONSTANTS ;LITERALS USED PREVIOUSLY MUST BE OUT OF BPS
SUBTTL INITIALIZATION CODE
;;; THIS CODE IS IN BINARY PROGRAM SPACE
.CRFOFF
OBTL: REPEAT KNOB, CONC OB,\.RPCNT
.CRFON
INITIALIZE:
IFN D10*HISEGMENT,[
SETZ FREEAC,
SETUWP FREEAC, ;FREEAC HAS OLD STATE OF HISEG-PURE BIT
.VALUE
] ;END OF IFN D10
IFN D10*PAGING,[
MOVEI FREEAC,MEMORY-1
HRRM FREEAC,.JBFF
CORE FREEAC,
.VALUE
IFN SAIL,[
HRRZ FREEAC,.JBSA ;SET DDT STARTING ADDRESS SO SAVE COMMAND WINS
SKIPN .JBDDT
SETDDT FREEAC,
] ;END IFN SAIL
] ;END IFN D10*PAGING
IFN ITS,[
MOVE TT,[4400,,400000+<<PDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<SPDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FXPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
] ;END OF IFN ITS
MOVE P,C2
MOVE SP,SC2
MOVE FXP,FXC2
;;; FALLS THROUGH
;INIBS INIBS1 INIBS2 INIT5
;;; FALLS IN
INIBS: MOVEI F,0 ;BUBBLE-SORT THE LAPFIV TABLE, WHILE
MOVEI C,LLSYMS-1 ;SORTING THE BSP TABLE AS SUBSIDIARY RECORDS
INIBS1: MOVE D,LAPFIV(C)
CAML D,LAPFIV-1(C)
JRST INIBS2
MOVEI F,1 ;FLAG TO NOTE THAT A BUBBLING OCCURED THIS PASS
EXCH D,LAPFIV-1(C)
MOVEM D,LAPFIV(C) ;INTERCHANGE KEYS
MOVE D,INIBSP(C)
EXCH D,INIBSP-1(C) ;INTERCHANGE RECORDS
MOVEM D,INIBSP(C)
INIBS2: SOJG C,INIBS1
JUMPN F,INIBS
MOVNI C,LLSYMS-1
MOVE AR2A,[441100,,LAP5P]
MOVE TT,INIBSP+LLSYMS-1(C)
IDPB TT,AR2A
AOJLE C,.-2
;;; INITIALIZE THE SEGMENT-LINK COUNTERS FOR ITS & D20
IFN PAGING,[
IRP A,,[FS,FX,FL,SY,SA,S2]B,,[IFS,IFX,IFL,SYM,SAR,IS2]
MOVEI T,L!B!SG
MOVEM T,A!SGLK
TERMIN
BG$ MOVEI T,LBNSG
BG$ MOVEM T,BNSGLK
IRPC Q,,[AB]
IFN NXX!Q!SG,[
MOVE T,IMSGLK
MOVE TT,[-NXX!Q!SG,,BXX!Q!SG←-SEGLOG]
DPB T,[SEGBYT,,GCST(TT)]
MOVEI T,(TT)
AOBJN TT,.-2
MOVEM T,IMSGLK
] ;END OF IFN NXX!Q!SG
TERMIN
MOVEI T,<<<ENDLISP+PAGSIZ-1>&PAGMSK>-BBPSSG>←-PAGLOG
MOVEI D,BBPSSG←-PAGLOG
ROT D,-4
ADDI D,(D)
ROT D,-1
TLC D,770000
ADD D,[450200,,PURTBL]
MOVEI TT,3
INIT5: TLNN D,730000
TLZ D,770000
IDPB TT,D
SOJG T,INIT5
MOVE T,[-<<<<ENDLISP+PAGSIZ-1>&PAGMSK>-BBPSSG>←-SEGLOG>,,ST+<BBPSSG←-SEGLOG>]
MOVE TT,[$XM,,QRANDOM]
MOVEM TT,(T)
AOBJN T,.-1
] ;END OF IFN PAGING
;BZERSG BSYSSG IN10ST IN10S5 IN10S8
IFE PAGING,[
;;; INITIALIZE THE SEGMENT TABLES, AND LINK COUNTERS FOR DEC-10
BZERSG==FIRSTLOC ;CROCK - BEWARE RELOCATION!
BSYSSG==HILOC
IN10ST: SETZ A, ;INIBD SETS NON-ZERO ON ERROR
MOVEI T,FIRSTLOC
MOVEI TT,FIRSTLOC ;DO NOT ATTEMPT TO PERFORM
SUBI TT,STDLO ; THIS ARITHMETIC AT ASSEMBLY
JSP F,INIBD ; TIME! WOULD USE WRONG
ASCIZ \LOW\ ; RELOCATION QUANTITIES
IFN HISEGMENT,[
MOVEI T,HILOC
MOVEI TT,HILOC
SUBI TT,STDHI
MOVEM TT,MAXNXM
SOS MAXNXM
JSP F,INIBD
ASCIZ \HIGH\
SKIPE A
EXIT ;LOSE LOSE
] ;END IFN HISEGMENT
HS% MOVEI TT,-1
HS% MOVEM TT,MAXNXM ;AS MUCH CORE AS IT WANTS TO USE!
MOVE T,[$NXM,,QRANDOM] ;INITIALIZE SEGMENT TABLES
MOVEM T,ST
MOVE T,[ST,,ST+1]
BLT T,ST+NSEGS-1
SETZM GCST
MOVE T,[GCST,,GCST+1]
BLT T,GCST+NSEGS-1
MOVEI AR1,BTBLKS ;AR1 ACTS AS BTB. [BIT-BLOCK COUNTER]
LSH AR1,5-SEGLOG
10ST ZER
10ST ST
10ST SAR,[SA,,QARRAY][GCBMRK+GCBSAR]SASGLK
10ST VC,[LS+VC,,QLIST][GCBMRK+GCBVC]
10ST IS2,,,S2SGLK
10ST SYM,[SY,,QSYMBOL][GCBMRK+GCBSYM]SYSGLK
10ST IFS,[LS+$FS,,QLIST][GCBMRK+GCBCDR+GCBCAR]FSSGLK,BITS
10ST IFX,[FX,,QFIXNUM][GCBMRK]FXSGLK,BITS
10ST IFL,[FL,,QFLONUM][GCBMRK]FLSGLK,BITS
BG$ 10ST BN,[BN,,QBIGNUM][GCBMRK+GCBCDR]BNSGLK,BITS
10ST BIT
10ST FXP,[FX+$PDLNM,,QFIXNUM]
10ST FLP,[FL+$PDLNM,,QFLONUM]
10ST P
10ST SP
10ST BPS
10ST SYS,[$XM+PUR,,QRANDOM]
10ST SY2
10ST PFS,[LS+$FS+PUR,,QLIST]
10ST PFX,[FX+PUR,,QFIXNUM]
10ST PFL,[FL+PUR,,QFLONUM]
IN10S5: HRRM AR1,BTBAOB
LSH AR1,SEGLOG-5
CAIN AR1,BFBTBS
JRST IN10S8
OUTSTR [ASCIZ \LOST WHILE INITIALIZING BIT BLOCKS
\]
EXIT 1,
IN10S8:
EXPUNGE BZERSG BSYSSG
] ;END OF IFE PAGING
;ININTR INIRND BINIT9 INIT1G INIT1A INIT1B INIT1D INIT1C INIT1X INIT2A INIT2B INIT7A INIT7B BINIT9 INIT99 INIT1P INIT1Q
ININTR: MOVE A,[-KNOB+1-10,,OBTFS+1] ;SET UP OBLIST-LINKING CONSING AREAS
HRRZM A,-1(A)
AOBJN A,.-1
MOVEI F,OBTFS
MOVEM F,FFS
MOVE F,[-KNOB,,OBTL]
HRRZ A,(F)
PUSHJ P,INTERN
AOBJN F,.-2
INIRND: JSP F,IRAND ;INITIALIZE RANDOM NUMBER GENERATOR
;INITIALIZE INTERRUPT MASKS IN MEMORY
10$ MOVE T,[STDMSK]
10% MOVE T,[DBGMSK]
MOVEM T,IMASK
IT$ MOVE T,[DBGMS2]
IT$ MOVEM T,IMASK2
IFN ITS,[
MOVE A,[SETO AR1,]
MOVEM A,PURIFY
MOVE A,BINIT9 ;CLOBBER INIT, SINCE ONLY NEED DO ONCE
MOVEM A,INITIALIZE
.BREAK 12,[..SSTA,,[LISPGO]] ;SET START ADDRESS
.CORE <ENDLISP+PAGSIZ-1>←-PAGLOG ;FLUSH PDL PAGES
.VALUE
BINIT9: .VALUE [ASCIZ \:≠INITIALIZED≠
\]
] ;END OF IFN ITS
IFN D10,[
MACROLOOP N2DIF,ZZD,*
IFN TOPS10\CMU,[
OPEN TMPC,INIT1P
JRST INIT1A
LOOKUP TMPC,INIT1Q
JRST INIT1A
CLOSE TMPC,
SKIPA A,[QLISP]
INIT1G: HRRZ A,(A)
HRRZ A,(A)
HLRZ B,(A) ;FLUSH THE "PPN" PROPERTY OF "LISP"
CAIE B,QPPN
JRST INIT1G
HRRZ A,(A)
HRRZM (A)
JRST INIT1X
INIT1A: OUTSTR [ASCIZ \What is the PPN of the area with the autoload files? \]
SETZB T,TT
INIT1B: INCHWL A
CAIE A,↑C
CAIN A,↑M
JRST INIT1C ;↑C OR <CR> TERMINATES PROGMR NUMBER
CAIL A,"0
CAILE A,"9
JRST INIT1D
IMULI TT,8 ;ACCUMULATE NUMBER BASE 8
ADDI TT,-"0(A)
JRST INIT1B
INIT1D: CAIE A,", ;COMMA SHOULD TERMINATE PROJ NUMBER
JRST INIT1B
MOVEM TT,IPPN1
SETZ TT,
JRST INIT1B
INIT1C: MOVEM TT,IPPN2
INIT1X: RELEASE TMPC,
] ;END OF IFN TOPS10\CMU
MOVE C,[LVRNO]
SETZ A,
INIT2A: SETZ B,
LSHC B,6
JUMPE B,INIT2B
IMULI A,10.
ADDI A,-'0(B)
JRST INIT2A
INIT2B: LSH A,30 ;VERSION NUMBER STORED IN LOC 137 AS
MOVEM A,137 ;0XXX00,,0
MOVEI A,LISPGO
HRRM A,.JBSA"
MOVEM A,INIT
;SA$ MOVEI FREEAC,1 ;SAIL SETUWP DOES NOT RETURN OLD VALUE IN AC AS DEC10
HS$ SA% SETUWP FREEAC, ;RESTORE WRITE PROTECT STATUS
HS$ SA% .VALUE
IFE SAIL,[
OUTSTR [ASCIZ \:$INITIALIZED$
\]
EXIT 1,
] ;END OF IFE SAIL
IFN SAIL,[
IFN HISEGMENT,[
SETZ T,
GETNAM T,
MOVEM T, SGANAM
; JRST INIT7B
PUSHJ P,SAVHGH ;SAVE HIGH SEGMENT AS SYS:MACLSP.SHR
JRST INIT7A
OUTSTR [ASCIZ \:$INITIALIZED; HIGH SEGMENT SAVED$
\]
SETZ T, ;RECALL THAT A CRUFTY CODE 15 MAKES PTLOAD HAPPY
MOVE TT,[440700,,[ASCIZ \SAVE SYS:MACLSP
\]]
PTLOAD T ;STICK SAVE COMMAND IN LINE EDITOR
MOVEI T,INIT99
HRRM T,RETHGH
JRST KILHGH ;FLUSH HIGH SEGMENT
INIT7A: OUTSTR [ASCIZ \:$FAILED TO SAVE HIGH SEGMENT$
\]
INIT7B: OUTSTR [ASCIZ \:$INITIALIZED$
\]
SETZ T, ;RECALL THAT A CRUFTY CODE 15 MAKES PTLOAD HAPPY
MOVE TT,[440700,,[ASCIZ \SSAVE SYS:MACLSP
\]]
PTLOAD T ;STICK SAVE COMMAND IN LINE EDITOR
EXIT 1,
] ;END IFN HISEGMENT
IFE HISEGMENT,[
OUTSTR [ASCIZ \:$INITIALIZED$
\]
EXIT 1,
JRST @.JBSA
] ;END IFE HISEGMENT
] ;END OF IFN SAIL
] ;END OF IFN D10
IFN D20,[
MOVE A,[SETO AR1,]
MOVEM A,PURIFY
MOVE A,BINIT9 ;CLOBBER INIT, SINCE ONLY NEED DO ONCE
MOVEM A,INITIALIZE
MOVEI 1,.FHSLF
MOVE 2,[1,,ENTVEC]
SEVEC
HRROI 1,[ASCIZ \
;Initialized
\]
PSOUT
SKIPN <.JBSYM==:116> ;ANY SYMBOL TABLE?
HALTF ;NOPE, DONE WITH INITIALIZATION
HRROI 1,[ASCIZ \;Dump symbol table to file \]
PSOUT
MOVEI 1,.PRIIN ;CLEAR TTY INPUT BUFFER
CFIBF
HRLZI 1,(GJ%SHT\GJ%CFM\GJ%FOU\GJ%MSG\GJ%FNS)
MOVE 2,[.PRIIN,,.PRIOU]
GTJFN ;GET JFN FOR THE SYMBOL FILE
HALTF ;OH WELL, WE WERE GONNA STOP ANYWAY
MOVE TT,1 ;REMEMBER THE FILE HANDLE FOR LATER USE
MOVE 2,[<44←36>+OF%WR] ;36 BIT BYTES, WRITE ACCESS
OPENF
HALTF
HRRZ 1,TT ;RESTORE JFN
MOVE 2,.JBSYM ;OUTPUT THE SYMBOL TABLE POINTER
BOUT ;OUTPUT THE AOBJN POINTER FIRST
HRRZ 1,TT ;RESTORE JFN
HRRZ 2,.JBSYM ;SYMBOL TABLE ADDRESS MINUS ONE
HRLI 2,444400 ;36 BIT BYTES
HLRE 3,.JBSYM ;GET NEGATIVE LENGTH OF SYMBOL TABLE
SOUT ;OUTPUT THE SYMBOL TABLE TO THE FILE
HRROI 1,SYMFIL ;BLOCK TO GET NAME OF SYMBOL FILE
HRRZ 2,TT ;GET JFN (LH ZERO)
SETZ 3, ;GETS A SPEC TO GET BACK TO THE FILE LATER
JFNS ;REMEMBER THE SYMBOL FILESEPC
HRRZ 1,TT ;CLOSE THE FILE
CLOSF
HALTF ;IGNORE FAILURE
HALTF ;RETURN TO SUPERIOR
BINIT9: JRST .+1
HRROI 1,[ASCIZ \
;Already initialized
\]
PSOUT
HALTF
] ;END IFN D20
INIT99: JRST LISPGO
IFN TOPS10\CMU,[
INIT1P: .IOBIN
SIXBIT \LISP\
0
INIT1Q: SIXBIT \BACKQ\
SIXBIT \FAS\
0
0
] ;END OF IFN TOPS10\CMU
;NOTINIT INIBSP INIBD INIBD1 KLINIT KLINI1 KLINI2
;;; NOTE THAT THE SECOND $ IN THE MESSAGE HERE IS A REAL DOLLAR SIGN,
;;; WHILE THE OTHER TWO ARE ALTMODES; THUS DDT WON'T GET SCREWED!
NOTINIT:
IFN ITS,[
.VALUE [ASCIZ \:≠LISP NOT INITIALIZED (USE INIT$G)≠
\]
] ;END OF IFN ITS
IFN D20,[
HRROI 1,[ASCIZ \:≠LISP NOT INITIALIZED (USE INIT$G)≠
\]
PSOUT
HALTF
] ;END OF IFN D20
INIBSP: REPEAT LLSYMS, .RPCNT
IFN D10,[
;;; ROUTINE TO CHECK SEGMENT BOUNDARIES, AND IF LOSING,
;;; TELL LOSER HOW TO WIN WITH LINK-10.
INIBD: TRNN TT,SEGKSM
JRST 1(F) ;WIN
SETO A,
OUTSTR (F)
OUTSTR [ASCIZ \ SEGMENT ON BAD BOUNDARY. TELL LINK "/SET:.\]
OUTSTR (F)
OUTSTR [ASCIZ \.:\]
ANDI TT,SEGKSM
ADDI T,SEGSIZ
SUBI T,(TT)
HRLZ TT,T
MOVEI D,6
INIBD1: SETZ T,
LSHC T,3
ADDI T,"0
OUTCHR T
SOJG D,INIBD1
OUTSTR [ASCIZ \"
\]
JRST 1(F)
] ;END OF IFN D10
IFN ITS,[
IFE SEGLOG-11,[ ;VARIOUS PARAMETERS BUILT INTO UCODE
IFLE HNKLOG-5,[
;;; KL-10 INIT ROUTINE
KLINIT: MOVE T,[-NSEGS,,GCST]
KLINI1: MOVE TT,(T)
IFN HNKLOG, TLNN TT,GCBFOO+GCBHNK
.ELSE TLNN TT,GCBFOO
JRST KLINI2
SETO D,
TLNE TT,GCBSYM
MOVEI D,0
TLNE TT,GCBVC
MOVEI D,1
TLNE TT,GCBSAR
MOVEI D,2
IFN HNKLOG,[
HRRZ R,ST(T)
TLNE TT,GCBHNK
2DIF [MOVEI D,(R)]3,QHUNK1
] ;END OF IFN HNKLOG
SKIPGE D
.VALUE
IFN HNKLOG, TLZ TT,GCBFOO+GCBHNK
.ELSE TLZ TT,GCBFOO
TLO TT,200000
DPB D,[330300,,TT]
MOVEM TT,(T)
KLINI2: AOBJN T,KLINI1
MOVE T,[JRST KLGCM1]
MOVEM T,GCMRK0
MOVE T,[JRST KLGCSW]
MOVEM T,GCSWP
.VALUE [ASCIZ \:≠INITIALIZED FOR KL-10≠
\]
] ;END OF IFLE HNKLOG-5
] ;END OF IFE SEGLOG-11
] ;END OF IFN ITS
;LOPDL LOFXPDL LOSPDL LOFLPDL ALBPS
IFN D10,[
LOPDL==200
LOFXPDL==100
LOSPDL==40
LOFLPDL==10
ALBPS==7000
SA$ ALBPS==ALBPS+4000
] ;END OF IFN D10
;XLABEL
SUBTTL HAIRY ALLHACK MACRO
DEFINE AMASC A,B
ASCIZ \
A!B \
TERMIN
DEFINE ALLHACK XLABEL,TP,NAME,STDALC,MINALC,EXTRA,WHERE,NWHERE
SKIPE ALLF
JRST XLABEL
PUSHJ P,ALLTYO
AMASC [TP! !NAME = ]\STDALC
MOVE AR1,[ASCII \NAME\]
PUSHJ P,ALLNUM
SKIPGE A
XLABEL: MOVEI A,STDALC
CAIGE A,MINALC
MOVEI A,MINALC
IFSN EXTRA,, ADDI A,EXTRA
HRRM A,WHERE
IFSN NWHERE,,[
MOVN B,A
HRRM B,NWHERE
]
PUSHJ P,ALLECO
TERMIN
;FAKJCL ALLF AINFIL ATYF LICACR ALERR ALLTYO ATYOI ALLECO SAILP4 SAIP1 SAIP2 SAIP3 ALLTYI ATI2 ATI1 ALLTYC ALOIOT
SUBTTL ALLOC I/O ROUTINES
10% ALLJCL: BLOCK 80. ;BUFFER UP JOB COMMAND LINE IF THERE WAS ONE.
10% ALJCLP: -1 ;ALLOW ONLY ONE TRY FOR JCL (JOB COMMAND LINE)
FAKJCL: 0 ;NON-ZERO MEANS LOOKING FOR INIT FILE, 0 MEANS JCL FILE
ALLF: 0 ;NON-ZERO FOR STANDARD ALLOCATION
AINFIL: 0 ;NON-NIL MEANS LOAD .LISP. (INIT) FILE AFTER ALLOCING
ATYF: 0 ;TTYOFF FOR ALLOC
LICACR: 0 ;LAST INPUTED CHAR TO ALLOC WAS A CR -1 ==> YES
ALERR: STRT [SIXBIT \GC CALLED FROM ALLOC - LOSE, LISP IS DEAD!\]
.VALUE
;;; PUSHJ P,ALLTYO ;PRINT ASCIZ STRING FOR ALLOC
;;; ASCIZ \TEXT...\ ;NOTE: ASCIZ IS NOT IN [ ... ] !
ALLTYO: HRLI A,440700
HLLM A,(P)
ATYOI: ILDB A,(P)
JUMPE A,POPJ1
SKIPN ATYF
PUSHJ P,ALLTYC
JRST ATYOI
ALLECO: SKIPL AFILRD
SKIPE ATYF
POPJ P,
PUSH P,A
MOVE TT,A
HRROI R,TYO
PUSHJ P,PRINL4
POP P,A
POPJ P,
IFN SAIL,[
SAILP4: CAIN C,32 ;A TILDE?
JRST SAIP1
CAIN C,176 ;A }
JRST SAIP2
CAIE C,175 ;AN ALTMODE
JRST SAIP3
MOVEI C,33
JRST SAIP3
SAIP1: MOVEI C,176
JRST SAIP3
SAIP2: MOVEI C,175
SAIP3: TRZE C,600 ;CTRL/META/BOTH?
TRZ C,140
CAIN C,121
MOVEI C,21
CAIN C,161
MOVEI C,21
CAIN C,127
MOVEI C,27
CAIN C,167
MOVEI C,27
POPJ P,
] ;END OF IFN SAIL
ALLTYI:
IFN ITS,[
.IOT 0,C ;CHANNEL NUMBER FILLED IN
] ;END OF IFN ITS
IFN D10,[
INCHRW C
SA$ PUSHJ P,SAILP4
AOSG LICACR
JRST ATI1
ATI2: CAIN C,↑M
SETOM LICACR
] ;END OF IFN D10
IFN D20,[
PUSH P,1
PBIN
MOVEI C,(1)
POP P,1
] ;END IFN D20
CAIN C,↑G
JRST ALLOC1
POPJ P,
IFN D10,[
ATI1: CAIN C,↑J ;FLUSH A SYSTEM-SUPPLIED LINE-FEED
INCHRW C ;FOLLOWING A CR
SA$ PUSHJ P,SAILP4
JRST ATI2
] ;END OF IFN D10
ALLTYC:
IFN ITS,[
CAIE A,↑J
ALOIOT:
.IOT 0,A ;WILL CLOBBER CHANNEL HERE
] ;END OF IFN ITS
10$ OUTCHR A
20$ PBOUT ;OUTPUT TO PRIMARY OUTPUT JFN
POPJ P,
;ALLRUB ALLNUM ALNM2 ALNM27 ALNM3 ALNMOK ALSYER ALNMER ALLNER
ALLRUB: PUSHJ P,ALLTYO
ASCIZ \XX
\
ALLNUM: SKIPGE C,AFILRD ;GETS A NUMBER FOR SOME STORAGE AREA SIZE
JRST ALNM1
ALNM2: JUMPN C,ALNM27
SETO A,
POPJ P,
ALNM27: HLRZ A,(C) ;SEARCH THE READ IN LIST TO SEE
HRRZ C,(C) ;WHETHER LOSER HAS TRIED TO SPECIFY
JUMPE C,ALLNER ;ALLOCATION FOR THIS QUANTITY
SKOTT A,SY
JRST ALSYER
HLRZ A,(A)
HRRZ A,1(A)
HLRZ AR2A,(A)
HLRZ A,(C)
CAMN AR1,(AR2A)
JRST ALNM3
HRRZ C,(C)
JRST ALNM2
ALNM3: MOVE TT,(A) ;GET NUMBER INTO TT
SKOTT A,FL ;IF FLOATING CONVERT TO FIXNUM
SKIPA
PUSHJ P,FIX2
SKOTT A,FX ;IS IT FIXNUM?
JRST ALNMER
ALNMOK: MOVE A,(A)
POPJ P,
ALSYER: MOVEI D,[SIXBIT \NON-SYMBOL ALLOCATION AREA!\]
JRST ALCLZ1
ALNMER: MOVEI D,[SIXBIT \NON-FIXNUM/FLONUM ALLOCATION QUANTITY!\]
JRST ALCLZ1
ALLNER: MOVEI D,[SIXBIT \ODD LENGTH ALLOCATION COMMENT!\]
JRST ALCLZ1
;ALNM1 ALNM1A DECDIG DDIG1
ALNM1: MOVSI B,400000
MOVSI A,400000 ;GET VALUE FROM TTY
ALNM1A: PUSHJ P,ALLTYI
CAIE C,12
CAIN C,15
POPJ P,
CAIE C,33 ;ALT MODE SAYS "DONE ALLOCING"
JRST .+3
SETOM ALLF
POPJ P,
CAIN C,".
MOVE A,B
MOVE D,RCT0(C)
TLNE D,170000
POPJ P,
CAIL C,"0
CAILE C,"9
JRST ALLRUB
TLZ A,400000
TLZ B,400000
IMULI A,10
ADDI A,-"0(C)
IMULI B,10.
ADDI B,-"0(C)
JRST ALNM1A
IFN D10,[
DECDIG: SKIPE ATYF
POPJ P,
JUMPN T,DDIG1
OUTCHR [ASCII \0\]
DDIG1: JUMPE T,CPOPJ
IDIVI T,10
PUSH P,TT
PUSHJ P,DECDIG
POP P,TT
ADDI TT,"0
OUTCHR TT
POPJ P,
] ;END OF IFN D10
;ALFDEF ALOFL2 ALOFIL ALOINI ALOJCL ALOIN1 ALOFL4 ALOFL1 ALOFL5 ALOFL6
SUBTTL ALLOC (INIT) FILE ROUTINES
;SETUP DEAFULT JCL
IFN D10,[
ALFDEF: SETOM FAKJCL ;JCL IS REALLY FAKE
MOVE TT,[ASCII\LISP \] ;DEFAULT JCL: LISP <CR>
MOVEM TT,SJCLBUF+1
MOVE TT,[ASCII\
\]
MOVEM TT,SJCLBUF+2
POPJ P,
] ;END IFN D10
IFN ITS,[
ALOFL2: CAMN A,[SIXBIT /*/] ;ALREADY TRIED **?
JRST ALFLER ;YUP, GIVE UP
MOVE A,@ALOFL2 ;ELSE TRY **
JRST ALOINI
] ;END IFN ITS
ALOFIL:
IFN ITS,[
MOVSI C,(SIXBIT \DSK\)
.SUSET [.RXUNAME,,A]
MOVE B,[SIXBIT \LISP\]
.SUSET [.RHSNAME,,F]
ALOINI: .CALL ALOFL6 ;DOES INIT FILE EXIST?
JRST ALOFL2
JRST ALOIN1 ;ELSE PROCEED NORMALLY
ALOJCL: .CALL ALOFL6 ;DOES JCL FILE EXIST?
JRST ALFLER ;NOPE, ERROR
ALOIN1: MOVEM C,INIIF2+F.DEV ;YES, SAVE FILE NAMES
MOVEM F,INIIF2+F.SNM
MOVEM A,INIIF2+F.FN1
MOVEM B,INIIF2+F.FN2
ALOFL4: .CLOSE TMPC,
] ;END IFN ITS
IFN D10,[
HRLZI C+1,(SIXBIT/DSK/)
MOVE A,[SIXBIT/LISP/]
HRLZI B,(SIXBIT/INI/)
ALOFL1: SETZB C,C+2
OPEN TMPC,C
JRST ALFLER ;NO DISK?
MOVEM C+1,INIIF2+F.DEV
SETZI C,
MOVE C+1,R ;GET SPECIFIED PPN
MOVEM C+1,INIIF2+F.PPN
LOOKUP TMPC,A
JRST ALFLER
MOVEM A,INIIF2+F.FN1
HLLZM B,INIIF2+F.FN2
CLOSE TMPC,
];END IFN D10
PUSH P,[ALOFL5]
PUSH P,[INIIFA]
PUSH P,[QNODEFAULT] ;DON'T MEREGE WITH DEFAULT FILENAMES
MOVNI T,2
JRST $EOPEN ;OPEN INIT FILE ARRAY
ALOFL5: MOVEM A,VINFILE
MOVEI A,TRUTH
MOVEM A,TAPRED
SETOM AFILRD
POPJ P,
IFN ITS,[
ALOFL6: SETZ
SIXBIT \OPEN\ ;OPEN FILE
5000,,2 ;MODE (ASCII BLOCK INPUT)
1000,,TMPC ;CHANNEL #
,,C ;DEVICE
,,A ;FILE NAME 1
,,B ;FILE NAME 2
400000,,F ;SNAME
];END IFN ITS
;ALLFIL ALLFL1 ALLFL2 ALCLUZ ALCLZ1 ALLTTS ALHELP
ALLFIL: PUSHJ P,ALOFIL ;OPEN INIT FILE
ALLFL1: SETZM BFPRDP
PUSHJ P,READ ;READ IN ALLOCATIONS "COMMENT"
SETZM ALGCF
HLRZ B,(A)
CAIE B,Q$COMMENT
JRST ALCLUZ
ALLFL2: HRRZ A,(A)
MOVEM A,AFILRD ;SAVE IT (ACTUALLY, ITS CDR)
JRST ALLOCC
ALCLUZ: MOVEI D,[SIXBIT \ALLOC COMMENT MISSING IN INIT FILE!\]
ALCLZ1: HRRZ A,VINFILE
SETZM VINFILE
PUSH FXP,D
PUSHJ P,$CLOSE
POP FXP,D
20% MOVE A,INIIF2+F.FN1
20% MOVE B,INIIF2+F.FN2
IT$ MOVE F,INIIF2+F.SNM
10$ MOVE F,INIIF2+F.PPN
20$ WARN [WHAT TO DO FOR FILE NOT FOUND ERROR FOR D20 ALLOC]
SETZM FAKJCL ;FORCE ERROR MESSAGE THROUGH EVEN IF FAKING JCL
JRST ALCERR
IFN ITS,[
ALLTTS: SETZ ;TTYSET FOR ALLOC - NO INTERRUPT CHARS!
SIXBIT \TTYSET\ ;SET TTY VARIABLES
,,TTYIF2+F.CHAN ;CHANNEL #
,,[STTYA1] ;TTYST1
400000,,[STTYA2]
] ;END OF IFN ITS
ALHELP: PUSHJ P,ALLTYO
ASCIZ \
N = DON'T ALLOCATE (I.E. USE DEFAULTS)
Y = ALLOC FROM TTY
↑Q = READ INIT FILE AND ALLOC FROM IT
↑S = ALLOC FROM TTY, THEN READ INIT FILE
↑W = SAME AS ↑Q, BUT NO ECHO ON TTY
ALTMODE, TYPED AT ANY TIME, TERMINATES ALLOCATION PHASE,
TAKING REMAINING PARAMETERS AS DEFAULTS.
↑G RESTARTS ALLOC.
LINES PROMPTED BY A "#" CANNOT BE RE-ALLOCATED AFTER RUNNING.
OTHERS CAN BE RE-ALLOCATED AT ANY TIME
WITH THE LISP FUNCTION "ALLOC".
TERMINATE EACH NUMERIC ENTRY WITH CR OR SPACE.
A CR OR SPACE TYPED WITHOUT A PRECEDING NUMBER
ASSUMES THE DEFAULT FOR THAT ENTRY.
RUBOUT RESTARTS THE CURRENT ENTRY.
NUMBERS ARE TYPED IN BASE EIGHT, UNLESS SUFFIXED BY ".",
IN WHICH CASE BASE TEN IS USED.
ALL ENTRIES ARE IN UNITS OF PDP-10 WORDS.
\
JRST ALLOC1
;ALFLER ALCERR ALFL6 ALFL6A ALFL6B
ALFLER: MOVEI D,[SIXBIT \ INIT FILE NOT FOUND!\]
ALCERR: SETZM TAPRED
SETZM TTYOFF
SETZM TAPWRT
AOSN FAKJCL ;DID WE FAKE JCL?
JRST POPJ1 ;YUP, THEN SKIP RETURN SO CAN DO ALLOC
STRT [SIXBIT \ !\]
IFN ITS,[
MOVE AR1,F
MOVEI T,";
PUSHJ P,ALFL6
] ;END OF IFN ITS
MOVE AR1,A
10% MOVEI T,40
10$ MOVEI T,".
PUSHJ P,ALFL6
MOVE AR1,B
MOVEI T,40
PUSHJ P,ALFL6
STRT (D)
SA$ CLRBFI ;CLEAR INPUT BUFFER FOR SAIL
MOVNI T,0 ;SETUP FOR NO ARG LSUBR CALL
JRST QUIT ; (VANILLA-FLAVORED QUIT)
ALFL6: EXCH A,R
SETZ AR2A,
MOVE TT,[440600,,AR1]
ALFL6A: ILDB A,TT
JUMPE A,ALFL6B
ADDI A,40
IT$ ALFL6C: .IOT 0,A ;CHANNEL # FILLED IN
10$ OUTCHR A
20$ PBOUT
JRST ALFL6A
ALFL6B: MOVE A,T
IT$ .IOT 0,A ;CHANNEL # FILLED IN
10$ OUTCHR A
20$ PBOUT
EXCH A,R
POPJ P,
;%ALLOC ALFDE1 ALJ1 ALJ1A ALJ1A1 ALJ1A2 ALJ1B ALJ1B1 ALJ1B2 ALJ2 ALJ2Q ALJ2A ALJ2A1 ALJ3 ALJ1 ALJ1A ALJ1A1 ALJ1A2 ALPPN1 ALJ1A3 ALJ1B ALJ1B2 ALJ2 ALJ2Q HAFPPN HAFPP1 ALJ3 ALLOCB
SUBTTL MAIN ALLOC INTERACTION CODE
%ALLOC:
IFN D10,[
SETZM LICACR ;LAST INPUT CHAR TO ALLOC WAS? CR - NO!
IFE SAIL,[
MOVEM 0,SGANAM ;SAVE MAGIC STUFF FOR GETHGH
MOVEM 11,SGADEV
MOVEM 7,SGAPPN
JSP T,D10SET
] ;END OF IFE SAIL
MOVEI A,ENDLISP+PAGSIZ-1;MUST DO CRUFTY CALCULATION BY HAND AS INVOLVES
ANDI A,PAGMSK ;BOOLEAN OPS AND RELOCATABLE SYMBOLS (BARF!!)
SUBI A,EINIFA
MOVEM A,IGCFX1
] ;END OF IFN D10
20$ JSP T,TNXSET ;DECIDE WHETHER TENEX OR TOPS20
; AND SET PAGE ACCESSIBILITY
MOVE A,[RCT0,,RCT]
BLT A,RCT+LRCT-1
IFN ITS,[
MOVE TT,[4400,,400000+<<PDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<SPDLORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FXPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
MOVE TT,[4400,,400000+<<FLPORG←-PAGLOG>←11>]
.CBLK TT,
.VALUE
] ;END OF IFN ITS
MOVE P,C2
MOVE SP,SC2
MOVE FXP,FXC2
MOVE FLP,FLC2
MOVE A,[-LFSALC+1,,FSALC+1] ;SET UP ALLOC CONSING AREAS
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-LFWSALC+1+NIFWAL,,FWSALC+1+NIFWAL]
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-LSYALC+1,,SYALC+1]
HRRZM A,-1(A)
AOBJN A,.-1
MOVE A,[-NIS2SG*SEGSIZ/2+1,,SY2ALC+2]
HRRZM A,-2(A)
ADDI A,1
AOBJN A,.-2
MOVE A,[-INFVCS+1,,BFVCS+1]
HRRZM A,-1(A)
AOBJN A,.-1
MOVEI A,FSALC ;SET UP PHONY FREELISTS
MOVEM A,FFS
MOVEI A,FWSALC+NIFWAL
MOVEM A,FFX
MOVEI A,SYALC
MOVEM A,FFY
SETOM ALGCF ;ERROR OUT ON GC (UNTIL FURTHER NOTICE)
SETZB NIL,ATYF
SETOM AFILRD
IT$ .SUSET [.RSNAM,,T]
10$ SA% GETPPN T,
10$ SA% JFCL
10$ SA$ SETZ T,
10$ SA$ DSKPPN T, ;AS SET BY ALIAS COMMAND
IRP FIL,,[TTYIF2,TTYOF2]
IT$ MOVEM T,FIL+F.SNM
10$ MOVEM T,FIL+F.PPN
TERMIN
IFE D20,[
PUSH FXP,[SIXBIT \DSK\]
PUSH FXP,T
SA% REPEAT 2, PUSH FXP,[SIXBIT \@\]
SA$ PUSH FXP, [SIXBIT \@\]
SA$ PUSH FXP, [SIXBIT \←←←\]
] ;END IFE D20
IFN D20,[
PUSH FXP,[ASCIZ \PS\] ;LOSE LOSE - ASSUME CONNECTED TO "PS:"
REPEAT L.6DEV-1, PUSH FXP,R70
JSP T,TNXUDI
MOVNI D,L.6DIR ;PUSHS THE DIRECTORY NAME
SETOM TT
SKIPE TT
SKIPN R,PNBUF+L.6DIR(D)
SETZB TT,R
PUSH FXP,R
AOJL D,.-4
PUSH FXP,[ASCIZ \FOO\] ;PUSH A "FOO" FOR FILE NAME
REPEAT L.6FNM-1, PUSH FXP,R70
PUSH FXP,[ASCIZ\LSP\]
REPEAT L.6EXT-1, PUSH FXP,R70
REPEAT L.6VRS, PUSH FXP,0
] ;END IFN D20
PUSHJ P,6BTNML
MOVEM A,VDEFAULTF
PUSHJ P,OPNTTY ;OPEN TTY INPUT AND OUTPUT
.VALUE ;MUST HAVE TTY TO DO ALLOC
IFN ITS,[
MOVE T,TTYOF2+F.CHAN ;INITIALIZE CHANNEL NUMBER FOR
DPB T,[270400,,ALOIOT] ; ALLOC'S OUTPUT .IOT TO TTY
DPB T,[270400,,ALFL6B]
DPB T,[270400,,ALFL6C]
MOVE T,TTYIF2+F.CHAN ;NOW DO THE SAME FOR
DPB T,[270400,,ALLTYI] ; THE INPUT .IOT
] ;END IFN ITS
IFN ITS,[
AOSE ALJCLP
JRST ALJ3
.SUSET [.ROPTION,,TT]
SETZM FAKJCL ;NOT FAKE JCL
TLNE TT,20000 ;NOT DDT ABOVE LISP
TLZN TT,40000 ;IF THERE IS JCL, TURN IT OFF AFTER READING
SOSA FAKJCL ;NO JOB COMMAND LINE, FLAG AS FAKE JCL
.BREAK 12,[..RJCL,,ALLJCL]
ALFDE1: SETZB A,C
SETZB D,F
SETZ B,
MOVE AR1,[440700,,ALLJCL]
ALJ1: MOVE AR2A,[440600,,T]
SETZ T,
ALJ1A: ILDB TT,AR1
JUMPE TT,ALJ2
CAIGE TT,"!
JRST ALJ1B
CAIE TT,":
JRST ALJ1A1
MOVE C,T
AOJA D,ALJ1
ALJ1A1: CAIE TT,";
JRST ALJ1A2
MOVE F,T
AOJA D,ALJ1
ALJ1A2: CAIL TT,"a ;LOWER-CASE
CAILE TT,"z
ADDI TT,40
ANDI TT,77
TLNE AR2A,770000
IDPB TT,AR2A
JRST ALJ1A
ALJ1B: JUMPE T,ALJ1B2
JUMPE A,ALJ1B1
MOVEM T,B
JRST ALJ1B2
ALJ1B1: MOVEM T,A
ALJ1B2: CAIN TT,33 ;ALTMODE MEANS INIT FILE CAN GET JCL
JRST ALJ2Q
CAIE TT,↑M
JRST ALJ1
ALJ2: .SUSET [.ROPTION,,TT]
TLZ TT,OPTCMD ;TURN OFF JCL
.SUSET [.SOPTION,,TT]
ALJ2Q: SKIPN C
MOVSI C,(SIXBIT \DSK\)
JUMPN A,ALJ2A
SKIPN FAKJCL ;IF JCL FAKED, ALWAYS READ INIT
JUMPE D,ALJ3 ;IF WAS REALLY NULL THEN DON'T TRY TO READ INIT
MOVE B,[SIXBIT \LISP\] ;ASSUME FN2 OF LISP
SKIPN F ;SNAME SPECIFIED?
.SUSET [.RHSNAME,,F] ;NOPE, USE THE HSNAME
.SUSET [.RXUNAME,,A] ;XUNAME IS FIRST TRY AT FN1
SETOM ATYF ;TURN OF TTY OUTPUT
PUSHJ P,ALOINI ;TRY TO FIND FILE, USE INIT FILE ALGORITHM
JRST ALLFL1 ;FILE FOUND
JRST ALJ2A1
ALJ2A:
SKIPN F ;DEFAULT SNAME?
.SUSET [.RSNAM,,F]
SKIPN B ;DEFAULT FN2?
MOVSI B,(SIXBIT />/)
SETOM ATYF
PUSHJ P,ALOJCL
JRST ALLFL1
ALJ2A1: SETZM ATYF ;TURN ON TTY I/O
ALJ3: .CALL ALLTTS
.VALUE
] ;END OF IFN ITS
IFN D10,[
SETZM FAKJCL ;NOT FAKE JCL YET
JSP F,JCLSET
SKIPN SJCLBUF+1 ;ANY JCL?
PUSHJ P,ALFDEF ;SETUP DEFAULT JCL
SETZB D,R ;D IS FLAG FOR . SEEN, R IS PPN
SETZB A,C
MOVSI B,(SIXBIT \INI\)
MOVE AR1,[440700,,SJCLBUF+1]
ALJ1: MOVE AR2A,[440600,,T]
SETZ T,
ALJ1A: ILDB TT,AR1
JUMPE TT,ALJ2
CAIGE TT,"!
JRST ALJ1B
CAIE TT,":
JRST ALJ1A1
MOVE C,T
JRST ALJ1
ALJ1A1: CAIE TT,".
JRST ALJ1A2
MOVE A,T
SETZ B,
AOJA D,ALJ1
ALJ1A2: CAIE TT,"[ ;START OF PPN SPEC?
JRST ALJ1A3
SA% GETPPN R, ;HOLD PPN IN R
SA% JFCL ;IGNORE FUNNY SKIP RETURNS
SA$ SETZ R,
SA$ DSKPPN R, ;ON SAIL USE ALIAS
PUSHJ P,HAFPPN ;READ 1/2 PPN, SKIP IF ZERO
HRL R,T
CAIE TT,", ;IF TERMINATOR NOT COMMA THEN GIVE UP ON PPN
JRST ALPPN1
PUSHJ P,HAFPPN ;READ THE OTHER HALF OF THE PPN
HRR R,T ;REPLACE IN GENERATED PPN
CAIE TT,"] ;TERMINATING CLOSE BRACKET?
ALPPN1: MOVE TT,C+2 ;NOPE, RESTORE OLD BYTE POINTER
JRST ALJ1
ALJ1A3: CAIL TT,"a ;LOWER CASE
CAILE TT,"z
ADDI TT,40
ANDI TT,77
TLNE AR2A,770000
IDPB TT,AR2A
JRST ALJ1A
ALJ1B: JUMPE T,ALJ1B2
SKIPN D
SKIPA A,T
HLLZ B,T
ALJ1B2: CAIN TT,33 ;ALT-MODE SAYS DONT FLUSH JCL
JRST ALJ2Q
CAIN TT,↑M
JRST ALJ1
ALJ2: SETZM SJCLBUF
ALJ2Q: SKIPN C+1,C
MOVSI C+1,(SIXBIT \DSK\)
SETOM ATYF
PUSHJ P,ALOFL1 ;SKIP RETURN MEANS INIT FILE NOT FOUND
JRST ALLFL1
SETZM ATYF ;TURN ON TTY I/O
JRST ALJ3
HAFPPN: SETZ T, ;START OFF WITH 0
MOVE C+2,AR1 ;SAVE CURRENT BYTE POINTER
ILDB TT,AR1
CAIL TT,"0 ;MUST BE NUMERIC
CAILE TT,"9
JRST HAFPP1
LSH T,3 ;ADD DIGIT INTO PPN
ADDI T,-"0(TT)
JRST HAFPPN
HAFPP1: SKIPN T ;SKIP RETURN IF T NIL
AOS (P)
POPJ P,
ALJ3:
] ;END OF IFN D10
PUSHJ P,ALLTYO
ASCIZ \
LISP \
MOVE B,[LVRNO]
ALLOCB: SETZ A,
LSHC A,6
JUMPE A,ALLOCA
ADDI A,40
PUSHJ P,ALLTYC
JRST ALLOCB
;ALLOCA ALLOC1
ALLOCA:
IFE ITS,[
PUSHJ P,ALLTYO
ASCIZ \ with NEW I/O\
]
ALLOC1: PUSHJ P,ALLTYO
ASCIZ \
Alloc? \
PUSHJ P,ALLTYI
SETZM ALLF
CAIN C,↑W
SETOM ATYF
CAIE C,↑W
CAIN C,↑Q
JRST ALLFIL
CAIE C,33 ;ALTMODE
CAIN C,40 ;SPACE
SETOM ALLF
CAIE C,↑S
JRST .+3
SETOM AINFIL
JRST ALLOCC
CAIE C,"n ;LOWER CASE
CAIN C,"N
SETOM ALLF
SKIPE ALLF
JRST ALLOCC
CAIE C,"Y
CAIN C,"y ;LOWER CASE
JRST ALLOCC
CAIN C,"?
JRST ALHELP
CAIE C,"H
CAIN C,"h ;LOWER CASE
JRST ALHELP
SA$ BEEP=047000,,400111
SA$ SETOM A
SA$ BEEP A,
SA% MOVEI A,↑G ;RANDOM ILLEGAL CHARACTER TO ALLOC
SA% PUSHJ P,ALLTYC
IT$ HRRZ TT,TTYIF2+F.CHAN
IT$ .CALL CKI2I
IT$ .VALUE
20$ MOVEI 1,.PRIIN
20$ CFIBF
JRST ALLOC1
;ALCORX ALCORE ALCORX ALCORE ALLOCC
IFN PAGING,[
ALCORX==<BBPSSG-SEGSIZ*<NIFSSG+NIFXSG+NIFLSG+NXXZSG>>/PAGSIZ
ALCORE==ALCORX+<MAXFFS+MAXFFX+MAXFFL+MAXFFB+MAXFFY+MAXFFA+PAGSIZ-1>/PAGSIZ
] ;END IFN PAGING
.ELSE [
ALCORX==<BBPSSG-FIRSTLOC+STDLO-SEGSIZ*<NIFSSG+NIFXSG+NIFLSG+NXXZSG>>/PAGSIZ
ALCORE==ALCORX+4
]
ALLOCC:
PG% ALLHACK ASBPS,#,BPS,ALBPS,ENDLISP-BBPSSG,,BPSH
ALLHACK ASRPDL,#,REGPDL,ALPDL,200,100,OC2
ALLHACK ASSPDL,#,SPECPDL,ALSPDL,200,100,OSC2
ALLHACK ASFXP,#,FXPDL,ALFXP,200,LSWS+12,OFXC2
ALLHACK ASFLP,#,FLPDL,ALFLP,10,10,OFLC2
10$ ALLHACK ASDDT,#,DDTSYMS,100,20,,SYMLO
ALLHACK ASLIST,,LIST,MAXFFS,200,,XFFS
ALLHACK ASSYM,,SYMBOL,MAXFFY,200,,XFFY
ALLHACK ASFIX,,FIXNUM,MAXFFX,200,,XFFX
ALLHACK ASFLO,,FLONUM,MAXFFL,200,,XFFL
IFN BIGNUM, ALLHACK ASBIG,,BIGNUM,MAXFFB,100,,XFFB
ALLHACK ASARY,,ARRAY,MAXFFA,100,,XFFA
PUSHJ P,ALLTYO
ASCIZ \
\
;ALLCZX
SUBTTL RUNTIME STORAGE ALLOCATION
MOVEI TT,ALCORX*PAGSIZ
IRP Q,,[S,X,L,B,Y,A]Z,,[FS,FX,FL,BN,SY,SA]N,,[NIFSSG+2,NIFXSG+2
NIFLSG+1,NBNSG,NSYMSG+1,NSARSG]FLG,,[1,1,1,BIGNUM,1,1]
IFN FLG,[
MOVEI T,<N>*SEGSIZ
CAML T,XFF!Q
MOVEM T,XFF!Q
MOVE T,XFF!Q
CAMGE T,G!Z!SIZ
MOVEM T,G!Z!SIZ
ADD TT,T
LSH T,-4 ;HACK
CAIGE T,SEGSIZ
MOVEI T,SEGSIZ
CAILE T,4000
MOVEI T,4000
CAML T,G!Z!SIZ
SUBM T,G!Z!SIZ
] ;END OF IFN FLG
TERMIN
MOVEI D,ALCORE
SUB D,TT
JUMPLE D,ALLCZX
IRP Q,,[S,X,L,Y]%%%,,[70.,15.,3.,12.]
MOVEI T,(D)
IMULI T,%%%
IDIVI T,100.
ADDM T,XFF!Q
TERMIN
ALLCZX==.
;FALLS THROUGH
;ALLCPD
;FALLS IN
IFN PAGING,[
ALLCPD: SETZ F,
MOVEI R,MEMORY-NSCRSG*SEGSIZ
IRP Q,,[SC2,C2,FLC2,FXC2]Y,,[1,0,0,0]W,,[SPDL,PDL,FLP,FXP]
MOVEI T,(R)
SUBI T,MIN!W
EXCH T,O!Q
CAIGE T,MIN!W
MOVEI T,MIN!W
MOVEM T,X!W
ADDI T,PAGSIZ-1+MIN!W
ANDI T,PAGMSK
MOVEI TT,(T)
LSH TT,-PAGLOG
SUBI F,(TT)
SUBI R,(T)
MOVEI D,PAGSIZ-20
CAML D,X!W
MOVE D,X!W
MOVNS D
HRLS D
HRRI D,(R)
IFN <Y>, ADD D,R70+Y
MOVEM D,Q
MOVEI D,(R)
ADD D,X!W
ANDI D,777760 ;KEEP AWAY FROM PAGE BOUNDARIES!
TRNN D,PAGKSM
SUBI D,20
MOVEM D,X!W
MOVEM D,Z!W
TERMIN
HRLM F,PDLFL1
IMULI F,SGS%PG
HRLM F,PDLFL2
MOVEI F,(R)
LSH F,-PAGLOG
HRRM F,PDLFL1
MOVEI F,(R)
LSH F,-SEGLOG
HRRM F,PDLFL2
SUBI R,1
MOVEM R,HINXM
HRRZ A,SC2
MOVEM A,ZSC2
HRRZ A,C2
ADDI A,1
MOVEM A,NPDLH
HRRZ A,FXC2
ADDI A,1
MOVEM A,NPDLL
JRST ALLDONE
] ;END OF IFN PAGING
;ALLCPD ALCPD1 SYMMV6 ALQX1 ALSGHK ALQX2
;FALLS IN
IFE PAGING,[
ALLCPD: MOVEI A,BFXPSG
MOVEM A,NPDLL
MOVEI B,LOFXPDL ;SET UP FXP
ADD B,OFXC2
ADDI B,SEGSIZ-1
ANDI B,SEGMSK
MOVNI C,-LOFXPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,FXC2
ADDI C,-LOFXPDL(B)
HRLI C,-LOFXPDL
MOVEM C,OFXC2
MOVE C,[FX+$PDLNM,,QFIXNUM]
JSP T,ALSGHK
MOVEI B,LOFLPDL ;SET UP FLP
ADD B,OFLC2
ADDI B,SEGSIZ-1
ANDI B,SEGMSK
MOVNI C,-LOFLPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,FLC2
ADDI C,-LOFLPDL(B)
HRLI C,-LOFLPDL
MOVEM C,OFLC2
MOVE C,[FL+$PDLNM,,QFLONUM]
JSP T,ALSGHK
MOVEM A,NPDLH
MOVEI B,LOPDL+LOSPDL+1 ;SET UP P AND SP
ADD B,OC2
ADD B,OSC2
MOVEI AR1,SEGSIZ-1(B)
ANDI AR1,SEGMSK
MOVEI AR2A,(AR1)
MOVEI F,(A)
SUBI AR1,(B)
LSH AR1,-1 ;SPLIT SEGMENT REMAINDER
MOVE B,OC2
ADDI B,LOPDL(AR1)
MOVNI C,-LOPDL(B)
MOVSI C,(C)
HRRI C,-1(A)
MOVEM C,C2
ADDI C,-LOPDL(B)
HRLI C,-LOPDL
MOVEM C,OC2
ADDI A,(B)
MOVE B,OSC2
ADDI B,LOSPDL+1(AR1)
MOVNI C,-LOSPDL-1(B)
MOVSI C,(C)
HRRI C,(A) .SEE UBD ;SP NEEDS FUNNY SLOT
MOVEM C,SC2
HRRZM C,ZSC2
ADDI C,-LOSPDL-1(B)
HRLI C,-LOSPDL
MOVEM C,OSC2
MOVEI A,(F)
MOVEI B,(AR2A)
MOVE C,[$XM,,QRANDOM]
JSP T,ALSGHK
MOVEM A,BPSL
MOVEM A,VBP1
MOVE C,A
ADDB C,BPSH ;FIRST ESTIMATE OF BPSH
HRRE B,.JBSYM
JUMPLE B,ALCPD1 ;ONLY HACK SYMBOLS IF IN LOW SEGMENT
SUB B,SYMLO
CAIG C,(B)
MOVE C,B
MOVEM C,BPSH ;SECOND ESTIMATE OF BPSH
ADD C,SYMLO
HLRE B,.JBSYM"
HRRO D,.JBSYM
SUB D,B
SUBI D,1 ;TO BE A PDL PTR IN THE SYMMOV
SUB C,B
ALCPD1: IORI C,SEGKSM ;HIGHEST ADDR FOR AUGMENTED SYMTAB
MOVEI B,1(C)
CAMG C,.JBFF
JRST .+3
CORE C,
JRST ALQX2
HRRM B,.JBFF"
MOVEI F,-1(B)
SUB B,BPSL ;TOTAL NUMBER WDS OCCUPIED BY RANDOM BPS AND SYMTAB
SUBI F,(D) ;TOTAL DISTANCE THAT SYMTAB MOVES
HRRE R,.JBSYM
JUMPLE R,ALQX1 ;ONLY HACK SYMBOLS IF THERE OR IN LOW SEGMENT
HLRE R,.JBSYM
JUMPE F,ALQX1
MOVE TT,[SYMMOV,,SYMMV1]
BLT TT,LPROGS
HRRI SYMMV1,(F)
JRST SYMMV1
SYMMV6: ADDI SYMMV1,1(D)
HRRM SYMMV1,.JBSYM"
SUB SYMMV1,SYMLO
SUBI SYMMV1,1
HRRZM SYMMV1,BPSH ;IF THERE WAS A SYMTAB, NOW WE KNOW WHERE BPSH IS
IFE SAIL,[
MOVE F,[112,,11]
GETTAB F,
SETZ F,
LDB F,[061400,,A]
CAIN F,3
HRRM SYMMV1,@770001 ;TENEX SIMULATOR FOR TOPS-10
] ;END OF IFE SAIL
ALQX1: MOVE C,SYMLO
ASH C,-1
MOVEM SYMLO ;CONVERT FROM # OF WORDS TO # OF ENTRIES
HRRZ C,BPSH
SUB C,IGCFX1 ;IF NEWIO, MUST ALLOW FOR INITIAL ARRAY
SUB C,IGCFX2 ;AND INIT FILE ARRAY
MOVEM C,VBPE1 ;INITIAL SETTING OF BPEND
MOVE C,[$XM,,QRANDOM]
JSP T,ALSGHK
MOVEI C,-1(A)
MOVEM C,HIXM
MOVEI B,HILOC
ANDI B,SEGMSK
SUBI B,(A)
MOVE C,[$NXM,,QRANDOM]
JSP T,ALSGHK
JRST ALLDONE
ALSGHK: MOVEI TT,(A)
MOVNI D,(B)
LSH TT,-SEGLOG
ASH D,-SEGLOG
HRLI TT,(D)
MOVEM C,ST(TT)
AOBJN TT,.-1
ADDI A,(B)
JRST (T)
ALQX2: PUSHJ P,ALLTYO
ASCIZ \
CAN'T GET ENOUGH CORE!\
JRST ALLOC1
] ;END OF IFE PAGING
;ALLDONE SYMMOV SYMMV1 LPROGS
;ALLDONE SYMMOV SYMMV1 LPROGS
ALLDONE:
MOVEI A,LISP
HRRM A,LISPSW
10$ MOVEI A,GOINIT
10$ HRRM A,.JBSA"
SETZM ALGCF ;GC IS OKAY NOW
JRST LISP
CONSTANTS ;ALLOC'S LITERALS GET EXPANDED HERE
IFE PAGING,[
SYMMOV: ;MOVE MOBY JOB SYMBOL TABLE UPWARDS
OFFSET C-.
SYMMV1: POP D,.(D) ;C
AOJL R,SYMMV1 ;AR1
JRST SYMMV6 ;AR2A
LPROGS==.-1
OFFSET 0
.HKILL SYMMV1
] ;END OF IFE PAGING
;INIIF1 INIIF2 FI.EOF FI.BBC FI.BBF F.MODE F.CHAN F.FLEN F.FPOS F.DEV F.RDEV F.DEV F.DIR F.FNM F.EXT F.VRS AT.CHS AT.LNN AT.PGN LONBFA FB.BYT FB.BFL FB.BVC FB.IBP FB.BP FB.CNT FB.HED FB.NBF FB.BWS FB.BUF LINIFA EINIFA ENDLISP ENDHI
;;; INITIAL ARRAYS IN SYSTEM GO HERE.
.SEE GCMKL
.SEE IGCMKL
.SEE VBPE1
SUBTTL INITIAL INIT FILE ARRAY FOR .LISP. (INIT) FILE
-F.GC,,INIIF2 ;GC AOBJN POINTER
INIIF1: JSP TT,1DIMS
INIIFA ;POINTER TO SAR
0 ;CAN'T ACCESS
INIIF2:
OFFSET -.
FI.EOF:: NIL ;EOF FUNCTION
FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS
FI.BBF:: NIL ;BUFFERED BACK FORMS
BLOCK 5
F.MODE:: 0 ;MODE (BLOCK ASCII DSK INPUT)
F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL)
20$ F.JFN:: -1 ;JOB-FILE NUMBER
20% 0
F.FLEN:: 0 ;FILE LENGTH
F.FPOS:: -1 ;FILEPOS
BLOCK 3
IFN ITS+D10,[
F.DEV:: SIXBIT \DSK\ ;DEVICE
IT$ F.SNM:: 0 ;SNAME (FILLED IN)
10$ F.PPN:: 0 ;PPN (FILLED IN)
IT$ F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1
10$ F.FN1:: SIXBIT \LISP\
IT$ F.FN2:: SIXBIT \(INIT)\ ;FILE NAME 2
10$ F.FN2:: SIXBIT \INI\
F.RDEV:: BLOCK 4 ;.RCHST'D NAMES
] ;END OF IFN ITS+D10
IFN D20,[
F.DEV:: ASCIZ \DSK\ ;DEVICE
BLOCK L.6DEV-<.-F.DEV>
F.DIR:: ;DIRECTORY (FILLED IN)
BLOCK L.6DIR-<.-F.DIR>
F.FNM:: ASCIZ \INIT\ ;FILE NAME
BLOCK L.6FNM-<.-F.FNM>
F.EXT:: ASCIZ \MACLISP\ ;EXTENSION
BLOCK L.6EXT-<.-F.EXT>
F.VRS:: ;VERSION
BLOCK L.6VRS
] ;END OF IFN D20
LOC INIIF2+LOPOFA
BLOCK 5
AT.CHS:: 0 ;CHARPOS
AT.LNN:: 0 ;LINENUM
AT.PGN:: 0 ;PAGENUM
BLOCK 10
LONBFA::
FB.BYT:: 0 ;BYTE SIZE
FB.BFL:: 0 ;BUFFER LENGTH
FB.BVC:: 0 ;COUNT OF VALID CHARACTERS
IFN ITS+D20,[
FB.IBP:: 0 ;INITIAL BYTE POINTER
FB.BP:: 0 ;BYTE POINTER
FB.CNT:: 0 ;CHARACTER COUNT
BLOCK 2
] ;END OF IFN ITS+D20
IFN D10,[
FB.HED:: 0 ;BUFFER HEADER
FB.NBF:: 0 ;NUMBER OF BUFFERS
FB.BWS:: 0 ;SIZE OF BUFFER IN WORDS
SA% 0
SA$ FB.ROF:: 0 ;RECORD OFFSET
BLOCK 1
] ;END OF IFN D10
FB.BUF::
IFN ITS+D20, BLOCK RBFSIZ
IFN D10, BLOCK NIOBFS*<LIOBUF+3>
OFFSET 0
LINIFA==:.-INIIF1+1 ;TOTAL NUMBER OF WORDS
EINIFA:: ;END OF ARRAY
-1 ;PHOOEY! FORCE THE "BLOCK" TO MAKE REAL 0'S
;;@ END OF ALLOC 220
PRINTX \
\ ;JUST TO MAKE LSPTTY LOOK NICER
EXPUNGE ZZ ZY ZX ZZX ZZY ZZZ ZZW
HS$ 10$ IF2, BSYSSG==400000 ;ANTI-RELOCATION CROCK
IF2, MACROLOOP NBITMACS,BTMC,* ;FOR BIT TYPEOUT MODE
ENDLISP:: ;END OF LISP, BY GEORGE!
VARIABLES ;NO ONE SHOULD USE VARIABLES!
IFN .-ENDLISP, WARN [OKAY, WHO'S THE WISE GUY USING VARIABLES?]
IFN D10,[
$HISEG
ENDHI:: ;END OF HIGH SEGMENT
] ;END OF IFN D10
IF2, ERRCNT==:.ERRCNT ;NUMBER OF ASSEMBLY ERRORS
END INITIALIZE
β